unit showmap;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, WIL, ComCtrls;
const
UNITX = 48;
UNITY = 32;
type
TMapInfo = packed record //这个好像不需要PACKED
BkImg: Word;
MidImg: Word;
FrImg: Word;
DoorIndex: byte;
DoorOffset: byte;
AniFrame: byte;
AniTick: byte;
Area: byte;
Light: byte;
end;
TMapHeader = packed record // MPA的头文件，需要PACKED，否则错误
Width: Word;
Height: word;
Title: string[15];
UpdateDate: TDateTime;
Reserved: array[0..23] of Char;
end;
TForm1 = class(TForm)
scrlbx1: TScrollBox;
pnl1: TPanel;
btnOpenMap: TButton;
pb1: TPaintBox;
dlgOpen1: TOpenDialog;
lbl1: TLabel;
lbl2: TLabel;
chkTiles: TCheckBox;
chkSmTiles: TCheckBox;
chkObjects: TCheckBox;
btnSaveTobmp: TButton;
lbl3: TLabel;
lbl4: TLabel;
lbl5: TLabel;
lbl6: TLabel;
trckbr1: TTrackBar;
lbl7: TLabel;
pbar1: TProgressBar;
lbl8: TLabel;
btnRefresh: TButton;
lbloj1: TLabel;
lbloj2: TLabel;
lbloj3: TLabel;
lbloj4: TLabel;
lbloj5: TLabel;
lbloj6: TLabel;
lbloj7: TLabel;
lbloj8: TLabel;
lbloj9: TLabel;
lbloj10: TLabel;
lbloj11: TLabel;
lbloj12: TLabel;
lbloj13: TLabel;
lbloj14: TLabel;
lbloj15: TLabel;
lbloj16: TLabel;
lbloj17: TLabel;
lblTil: TLabel;
lblSmT: TLabel;
procedure FormCreate(Sender: TObject);
procedure btnOpenMapClick(Sender: TObject);
procedure pb1Paint(Sender: TObject);
procedure btnSaveTobmpClick(Sender: TObject);
procedure trckbr1Change(Sender: TObject);
procedure btnRefreshClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
function LoadMapFile(flname: string): Boolean;
procedure ShowTiles(Canvas: TCanvas; x, y: Integer);
procedure ShowSmTiles(Canvas: TCanvas; x, y: Integer);
procedure ShowObjects(Canvas: TCanvas; x, y: Integer);
procedure clslbloj;
public
{ Public declarations }
end;
var
Form1: TForm1;
MArr : array[0..1000, 0..1000] of TMapInfo;
MapWidth, MapHeight : Integer;
BaseDir: string;
Zoom: Real;
wilTiles, wilSmTiles: TWMImages;
wil1, wil2, wil3, wil4, wil5, wil6,wil7, wil8, wil9, wil10 : TWMImages;
wil13, wil14, wil15: TWMImages;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
MapWidth := 1;
MapHeight := 1;
trckbr1Change(Sender);
BaseDir := GetCurrentDir + '\';
form1.Caption := BaseDir;
clslbloj;
if FileExists(BaseDir + 'Tiles.wil') then
begin
wilTiles := TWMImages.Create(Self);
wilTiles.FileName :=BaseDir + 'Tiles.wil';
wilTiles.Initialize;
lblTil.Caption := 'Tiles';
lblTil.Color := clGreen;
end;
if FileExists(BaseDir + 'SmTiles.wil') then
begin
wilSmTiles := TWMImages.Create(Self);
wilSmTiles.FileName :=BaseDir + 'SmTiles.wil';
wilSmTiles.Initialize;
lblSmT.Caption := 'SmTiles';
lblSmT.Color := clGreen;
end;
if FileExists(BaseDir + 'objects.wil') then
begin
wil1 := TWMImages.Create(Self);
wil1.FileName :=BaseDir + 'objects.wil';
wil1.Initialize;
lbloj1.Color := clGreen;
end;
if FileExists(BaseDir + 'objects2.wil') then
begin
wil2 := TWMImages.Create(Self);
wil2.FileName :=BaseDir + 'objects2.wil';
wil2.Initialize;
lbloj2.Color := clGreen;
end;
if FileExists(BaseDir + 'objects3.wil') then
begin
wil3 := TWMImages.Create(Self);
wil3.FileName :=BaseDir + 'objects3.wil';
wil3.Initialize;
lbloj3.Color := clGreen;
end;
if FileExists(BaseDir + 'objects4.wil') then
begin
wil4 := TWMImages.Create(Self);
wil4.FileName :=BaseDir + 'objects4.wil';
wil4.Initialize;
lbloj4.Color := clGreen;
end;
if FileExists(BaseDir + 'objects5.wil') then
begin
wil5 := TWMImages.Create(Self);
wil5.FileName :=BaseDir + 'objects5.wil';
wil5.Initialize;
lbloj5.Color := clGreen;
end;
if FileExists(BaseDir + 'objects6.wil') then
begin
wil6 := TWMImages.Create(Self);
wil6.FileName :=BaseDir + 'objects6.wil';
wil6.Initialize;
lbloj6.Color := clGreen;
end;
if FileExists(BaseDir + 'objects7.wil') then
begin
wil7 := TWMImages.Create(Self);
wil7.FileName :=BaseDir + 'objects7.wil';
wil7.Initialize;
lbloj7.Color := clGreen;
end;
if FileExists(BaseDir + 'objects8.wil') then
begin
wil8 := TWMImages.Create(Self);
wil8.FileName :=BaseDir + 'objects8.wil';
wil8.Initialize;
lbloj8.Color := clGreen;
end;
if FileExists(BaseDir + 'objects9.wil') then
begin
wil9 := TWMImages.Create(Self);
wil9.FileName :=BaseDir + 'objects9.wil';
wil9.Initialize;
lbloj9.Color := clGreen;
end;
if FileExists(BaseDir + 'objects10.wil') then
begin
wil10 := TWMImages.Create(Self);
wil10.FileName :=BaseDir + 'objects.wil';
wil10.Initialize;
lbloj10.Color := clGreen;
end;
if FileExists(BaseDir + 'objects13.wil') then
begin
wil13 := TWMImages.Create(Self);
wil13.FileName :=BaseDir + 'objects13.wil';
wil13.Initialize;
lbloj13.Color := clGreen;
end;
if FileExists(BaseDir + 'objects14.wil') then
begin
wil14 := TWMImages.Create(Self);
wil14.FileName :=BaseDir + 'objects14.wil';
wil14.Initialize;
lbloj14.Color := clGreen;
end;
if FileExists(BaseDir + 'objects15.wil') then
begin
wil15 := TWMImages.Create(Self);
wil15.FileName :=BaseDir + 'objects15.wil';
wil15.Initialize;
lbloj15.Color := clGreen;
end;
end;
function TForm1.LoadMapFile(flname: string): Boolean;
var
i, fhandle: Integer;
header: TMapHeader;
begin
Result := False;
if not FileExists(flname) then Exit;
fhandle := FileOpen(flname, fmOpenRead or fmShareDenyNone);
if fhandle > 0 then
begin
FillChar(MArr, SizeOf(MArr), #0);
FileRead(fhandle, header, SizeOf(TMapHeader));
lbl2.Caption := IntToStr(header.Width) + ' * ' + IntToStr(header.Height);
lbl3.Caption := header.Title;
lbl4.Caption := DateTimeToStr(header.UpdateDate);
lbl5.Caption := header.Reserved;
if (header.Width > 0) and (header.Height > 0) then
begin
MapWidth := header.Width;
MapHeight := header.Height;
for i := 0 to header.Width - 1 do
FileRead(fhandle, MArr[i, 0], SizeOf(TMapInfo) * MapHeight);
Result := True;
end;
FileClose(fhandle);
end;
end;
procedure TForm1.btnOpenMapClick(Sender: TObject);
begin
with dlgOpen1 do
begin
if Execute then
begin
if LoadMapFile(FileName) then
begin
lbl1.Caption := ExtractFileName(FileName);
lbl6.Caption := 'Img not draw.';
clslbloj;
trckbr1.Position := 9;
pb1.Refresh;
end;
end;
end;
end;
procedure TForm1.pb1Paint(Sender: TObject);
var
i, j, lcorner, tcorner: Integer;
begin
pb1.Width := Round(MapWidth * UNITX * Zoom);
pb1.Height := Round(MapHeight * UNITY * Zoom);
lbl8.Caption := IntToStr(pb1.Width) + ' * ' + IntToStr(pb1.Height);
//ShowBackgroundTile
lcorner := Trunc(scrlbx1.HorzScrollBar.Position div UNITX / Zoom) ; //水平线
tcorner := Trunc(scrlbx1.VertScrollBar.Position div UNITY / Zoom); //垂直线
for j := 0 to MapHeight - 1 do
for i := 0 to MapWidth - 1 do
begin
Application.ProcessMessages;
if (i >= lcorner - 1) and (i <= lcorner + Round(scrlbx1.Width div UNITX / Zoom) + 2) and
(j >= tcorner - 1) and (j <= tcorner + Round(scrlbx1.Height div UNITY / Zoom) + 10) then
begin
if chkTiles.Checked then
ShowTiles(pb1.Canvas, i, j);
if chkSmTiles.Checked then
ShowSmTiles(pb1.Canvas, i, j);
if chkObjects.Checked then
ShowObjects(pb1.Canvas, i, j);
end;
end;
end;
// 大瓦片tiles 96 * 64
procedure TForm1.ShowTiles(Canvas: TCanvas; x, y: Integer);
var
idx, xx, yy: Integer;
begin
if (x mod 2 = 0) and (y mod 2 = 0) then
begin
idx := (MArr[x, y].BkImg and $7fff ) - 1;
if idx >= 0 then
begin
lblTil.Caption := 'useTiles';
xx := Round(x * UNITX * Zoom);
yy := Round(y * UNITY * Zoom);
wilTiles.DrawZoom(Canvas, xx, yy, idx, Zoom);
end;
end;
end;
procedure TForm1.ShowSmTiles(Canvas: TCanvas; x, y: Integer);
var
idx, xx, yy : Integer;
begin
idx := (MArr[x, y].MidImg and $7fff) - 1;
if idx >= 0 then
begin
lblSmT.Caption := 'useSmTil';
xx := Round(x * UNITX * Zoom);
yy := Round(y * UNITY * Zoom);
wilSmTiles.DrawZoomEx(Canvas, xx, yy, idx, Zoom, True);
end;
end;
procedure TForm1.ShowObjects(Canvas: TCanvas; x, y: Integer);
var
idx, xx, yy: Integer;
begin
idx := (MArr[x, y].FrImg and $7fff) - 1 ; // objects 48 * n
//需要 +1位置放置
if idx > 0 then
begin
xx := Round(x* UNITX * Zoom);
yy := Round((y + 1) * UNITY * Zoom);
case (MArr[x, y].Area) of
0: begin
lbloj1.Caption := 'use01';
wil1.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
1: begin
lbloj2.Caption := 'use02';
wil2.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
2: begin
lbloj3.Caption := 'use03';
wil3.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
3: begin
lbloj4.Caption := 'use04';
wil4.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
4: begin
lbloj5.Caption := 'use05';
wil5.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
5: begin
lbloj6.Caption := 'use06';
wil6.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
6: begin
lbloj7.Caption := 'use07';
wil7.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
7: begin
lbloj8.Caption := 'use08';
wil8.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
8: begin
lbloj9.Caption := 'use09';
wil9.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
9: begin
lbloj10.Caption := 'use10';
wil10.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
10: begin
lbloj11.Caption := 'use*11';
end;
11: begin
lbloj12.Caption := 'use*12';
end;
12: begin
lbloj13.Caption := 'use13';
wil13.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
13: begin
lbloj14.Caption := 'use14';
wil14.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
14: begin
lbloj15.Caption := 'use15';
wil15.DrawZoomEx(Canvas, xx, yy, idx, Zoom, False);
end;
15: begin
lbloj16.Caption := 'use*16';
end;
16..255: begin
lbloj17.Caption :='use*' + IntToStr(MArr[x, y].Area);
end;
end;
end;
end;
procedure TForm1.btnSaveTobmpClick(Sender: TObject);
var
i, j: Integer;
str: string;
Bitmap: TBitmap;
begin
if dlgOpen1.FileName <> '' then
begin
str := dlgOpen1.FileName + '.bmp';
i := Round(MapWidth * UNITX * Zoom);
j := Round(MapHeight * UNITY * Zoom);
if (i <= 3000) and (j <= 3000) then
begin
Bitmap := TBitmap.Create;
Bitmap.Width := i;
Bitmap.Height := j;
pbar1.Position := 0;
pbar1.Max := MapHeight;
for j := 0 to MapHeight - 1 do
begin
for i := 0 to MapWidth - 1 do
begin
Application.ProcessMessages;
if chkTiles.Checked then
ShowTiles(Bitmap.Canvas, i, j);
if chkSmTiles.Checked then
ShowSmTiles(Bitmap.Canvas, i, j);
if chkObjects.Checked then
ShowObjects(Bitmap.Canvas, i, j);
end;
pbar1.StepIt;
end;
Bitmap.SaveToFile(str);
lbl6.Caption := 'Bmp have drawed.';
pbar1.Position := 0;
Bitmap.Free;
end else
lbl6.Caption := 'Bmp is to large.';
end;
end;
procedure TForm1.trckbr1Change(Sender: TObject);
begin
case trckbr1.Position of
1: Zoom := 0.015625;
2: Zoom := 0.03125;
3: Zoom := 0.0625;
4: Zoom := 0.09375;
5: Zoom := 0.125;
6: Zoom := 0.25;
7: Zoom := 0.5;
8: Zoom := 0.75;
9: Zoom := 1.0;
end;
lbl7.Caption := FloatToStr(Zoom);
end;
procedure TForm1.btnRefreshClick(Sender: TObject);
begin
pb1.Refresh;
end;
procedure TForm1.clslbloj;
begin
lblTil.Caption := 'Tiles';
lblSmT.Caption := 'smTiles';
lbloj1.Caption := '1';
lbloj2.Caption := '2';
lbloj3.Caption := '3';
lbloj4.Caption := '4';
lbloj5.Caption := '5';
lbloj6.Caption := '6';
lbloj7.Caption := '7';
lbloj8.Caption := '8';
lbloj9.Caption := '9';
lbloj10.Caption := '10';
lbloj11.Caption := '*11';
lbloj12.Caption := '*12';
lbloj13.Caption := '13';
lbloj14.Caption := '14';
lbloj15.Caption := '15';
lbloj16.Caption := '*16';
lbloj17.Caption := '*17-255';
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if wilTiles <> nil then wilTiles.Free;
if wilSmTiles <> nil then wilSmTiles.Free;
if wil1 <> nil then wil1.Free;
if wil2 <> nil then wil2.Free;
if wil3 <> nil then wil3.Free;
if wil4 <> nil then wil4.Free;
if wil5 <> nil then wil5.Free;
if wil6 <> nil then wil6.Free;
if wil7 <> nil then wil7.Free;
if wil8 <> nil then wil8.Free;
if wil9 <> nil then wil9.Free;
if wil10 <> nil then wil10.Free;
if wil13 <> nil then wil13.Free;
if wil14 <> nil then wil14.Free;
if wil15 <> nil then wil15.Free;
end;
end.
重点：
MAP文件机构
TMapHeader = packed record
Width: Word;
Height: word;
Title: string[15];
UpdateDate: TDateTime;
Reserved: array[0..23] of Char;
end;
TMapInfo = packed record
BkImg: Word;
MidImg: Word;
FrImg: Word;
DoorIndex: byte;
DoorOffset: byte;
AniFrame: byte;
AniTick: byte;
Area: byte;
Light: byte;
end;
重点文件
控件 WIL,
思路：
2023-3-27
1，显示头文件信息
TMapHeader = packed record
Width: Word;
Height: word;
Title: string[15];
UpdateDate: TDateTime;
Reserved: array[0..23] of Char;
end;
已经完成
3，可以放大缩小
2，加入图像控件可以保存大图片的。
GDIPLUS
'E:\mirClient\Mir1.76\Map\0125.map.bmp'
这个GDI+ 用了下，看起来并不是封装好的控件，也并不是图像控件。
而是对于一些函数的封装和应用。。。
我来试下 PAINTBOX.
PAINTBOX的CANVAS 没有保存到文件的函数。
测试得BITMAP的WIDTH HEIGHT 在3060 再大了就错误了
用IMAGE的CANVAS 画布可以装的下，
但是这个画布保存不了文件，
要保存到文件还是得进过BITMAP 于是又到了BITMAP大小限制的地方。
用了JPEG 不行， 其根子 是读取的图片文件的。
可以扫描CANVAS 写流数据直接到图片文件中，
这个难了我现在搞不定，需要用到太多的函数。
那我现在先缩小图片，最大限制到3060不就可以了吗，总比大图片显示不出来要强些。
3，可以放大缩小
delphi 常用函数(数学函数）round、trunc、ceil和floor
delphi 常用函数(数学)
2023年3月27日星期一16:44:03
加入缩小放大功能
17:48:08
放大缩小功能成功，发现按照2的倍数 不会出现白线，于是设置固定 倍数。
4, 显示使用的objects 文件序号。
DATA
1.5 ,1.76 : OBJECTS 2-7
1.8 , OBJECTS 2- 10
sf,ip ,通用版 2-10, 13-15;
2023年3月28日星期二
上午 8:50:26
1,只用1个objects wil.
这个没有成功，WIL控件里面的对象似乎不能很好被释放掉，
对于大地图需要多达几万次的对 WMIMAGEL类构建，析构，结果程序就崩掉了
只有使用多个WMIMAGE类了的对象了。。。最后程序关闭的时候析构掉。
还有些想法，比如使用自己编辑的MYWIL 单元，
按理说可以，但是发现自己编写的 MYWIL 单元里面的DRAWZOOM 函数是被彻底的改编了，需要的参数都不一样，
需要重新写，放弃了，
基本原理已经知道了，
感觉继续深入下去还是会放弃 DXD7这个控件，
会重新编写WIL单元，直接上 DX 的API 了。
这个里面就需要剔除掉DIB单元，是直接读取数据到BMP了。
下一步，带DXD7客户端了。。。
标签：MAP,begin,wil,end,BaseDir,Zoom,Caption,MapEdit,源程序 From： https://www.cnblogs.com/D7mir/p/17276714.html