?? wil.pas.svn-base
字號:
unit WIL;
interface
uses
Windows, Classes, Graphics, SysUtils, Dialogs,
wmUtil, HUtil32,
Direct3D, DIB, AsphyreDef, AsphyreDevices, AsphyreImages, DXTextures;
const
UseDIBSurface : Boolean = FALSE;
BoWilNoCache : Boolean = FALSE;
WilVersion: integer = 20020;
WixVersion: integer = 20021;
WilTaiwan = 20030;
WixTaiwan = 20031;
WilChinesse = 20040;
WixChinesse = 20041;
WilEnglish = 20050;
WixEnglish = 20051;
WilMagicCode = $C02a1173;
WixMagicCode = $B13a11F0;
type
TLibType = (ltLoadBmp, ltLoadMemory, ltLoadMunual, ltUseCache);
TInternationalVersion = (ivKorean, ivTaiwan, ivChinesse, ivEnglish);
TBmpImage = record
bmp: TBitmap;
LatestTime: integer;
end;
PTBmpImage = ^TBmpImage;
TBmpImageArr = array[0..MaxListSize div 4] of TBmpImage;
TDxImageArr = array[0..MaxListSize div 4] of TDxImage;
PTBmpImageArr = ^TBmpImageArr;
PTDxImageArr = ^TDxImageArr;
TWMImages = class (TComponent)
private
FFileName: string;
FImageCount: integer;
FLibType: TLibType;
FDxDevice: TAsphyreDevice;
FMaxMemorySize: integer;
OldVersionWil: Boolean;
procedure LoadAllData;
procedure LoadAllDataBmp;
procedure LoadIndex (idxfile: string);
procedure LoadDxImage (position: integer; pdximg: PTDxImage);
procedure LoadBmpImage (position: integer; pbmpimg: PTBmpImage);
procedure FreeOldMemorys;
function FGetImageSurface (index: integer): TAsphyreImage;
procedure FSetDxDevice (fdd: TAsphyreDevice);
procedure FreeOldBmps;
function FGetImageBitmap (index: integer): TBitmap;
protected
//MemorySize: integer;
lsDib: TDib;
memchecktime: longword;
public
ImgArr: PTDxImageArr;
BmpArr: PTBmpImageArr;
IndexList: TList;
//BmpList: TList;
Stream: TFileStream;
//MainSurfacePalette: TDirectDrawPalette;
MainPalette: TRgbQuads;
InternationalVersion: TInternationalVersion;
constructor Create (AOwner: TComponent); override;
destructor Destroy; override;
procedure Initialize;
procedure Finalize;
procedure ClearCache;
procedure LoadPalette;
procedure FreeBitmap (index: integer);
function GetImage (index: integer; var px, py: integer): TAsphyreImage;
function GetCachedImage (index: integer; var px, py: integer): TAsphyreImage;
function GetCachedSurface (index: integer): TAsphyreImage;
function GetCachedBitmap (index: integer): TBitmap;
procedure DrawZoom (paper: TCanvas; x, y, index: integer; zoom: Real);
procedure DrawZoomEx (paper: TCanvas; x, y, index: integer; zoom: Real; leftzero: Boolean);
property Images[index: integer]: TAsphyreImage read FGetImageSurface;
property Bitmaps[Index: Integer]: TBitmap read FGetImageBitmap;
published
property FileName: string read FFileName write FFileName;
property ImageCount: integer read FImageCount;
property DxDxDevice: TAsphyreDevice read FDxDevice write FSetDxDevice;
property LibType: TLibType read FLibType write FLibType;
property MaxMemorySize: integer read FMaxMemorySize write FMaxMemorySize;
end;
function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads; AllowPalette256: Boolean): TPaletteEntries;
procedure Register;
implementation
//uses
// ClMain; //唱吝俊 瘤匡 巴.
procedure Register;
begin
RegisterComponents('Zura', [TWmImages]);
end;
constructor TWMImages.Create (AOwner: TComponent);
begin
inherited Create (AOwner);
FFileName := '';
FLibType := ltLoadBmp;
FImageCount := 0;
//MemorySize := 0;
FMaxMemorySize := 1024*1000; //1M
FDxDevice := nil;
Stream := nil;
ImgArr := nil;
BmpArr := nil;
IndexList := TList.Create;
lsDib := TDib.Create;
lsDib.BitCount := 8;
//BmpList := TList.Create; //Bmp儈欄肺 葷儈且 錠鞏 葷儈
memchecktime := GetTickCount;
OldVersionWil := FALSE;
InternationalVersion := ivKorean;
end;
destructor TWMImages.Destroy;
begin
IndexList.Free;
// BmpList.Free;
if Stream <> nil then Stream.Free;
lsDib.Free;
inherited Destroy;
end;
procedure TWMImages.Initialize;
var
idxfile: string;
headerEx: TWMImageHeaderEx;
begin
if not (csDesigning in ComponentState) then begin
if FFileName = '' then begin
raise Exception.Create ('FileName not assigned..');
exit;
end;
if (LibType <> ltLoadBmp) and (FDxDevice = nil) then begin
raise Exception.Create ('AsphyreDevice not assigned..');
exit;
end;
if FileExists (FFileName) then begin
if Stream = nil then
Stream := TFileStream.Create (FFileName, fmOpenRead or fmShareDenyNone);
Stream.Read (headerex, sizeof(TWMImageHeaderex));
case InternationalVersion of
//ivKorean: wilv := WilVersion;
ivTaiwan:
begin
WilVersion := WilTaiwan;
WixVersion := WixTaiwan;
end;
ivChinesse:
begin
WilVersion := WilChinesse;
WixVersion := WixChinesse;
end;
ivEnglish:
begin
WilVersion := WilEnglish;
WixVersion := WixEnglish;
end;
end;
if longword(headerex.VersionInfo) <> longword(WilVersion + headerex.ImageCount) xor WilMagicCode then begin //撈傈 滾傈 牢 版快
OldVersionWil := TRUE;
Stream.Seek (- sizeof(integer), soFromCurrent);
end;
FImageCount := headerex.ImageCount;
if LibType = ltLoadBmp then begin
BmpArr := AllocMem (sizeof(TBmpImage) * FImageCount);
if BmpArr = nil then
raise Exception.Create (self.Name + ' BmpArr = nil');
end else begin
ImgArr := AllocMem (sizeof(TDxImage) * FImageCount);
if ImgArr = nil then
raise Exception.Create (self.Name + ' ImgArr = nil');
end;
idxfile := ExtractFilePath(FFileName) + ExtractFileNameOnly(FFileName) + '.WIX';
LoadPalette;
if LibType = ltLoadMemory then
LoadAllData
else begin
LoadIndex (idxfile);
end;
end else begin
MessageDlg (FFileName + ' Cannot find file.', mtWarning, [mbOk], 0);
end;
end;
end;
procedure TWMImages.Finalize;
var
i: integer;
begin
if ImgArr <> nil then begin
for i:=0 to FImageCount-1 do begin
if ImgArr[i].Surface <> nil then begin
ImgArr[i].Surface.Free;
ImgArr[i].Surface := nil;
end;
end;
end;
if Stream <> nil then begin
Stream.Free;
Stream := nil;
end;
end;
function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
AllowPalette256: Boolean): TPaletteEntries;
var
Entries: TPaletteEntries;
dc: THandle;
i: Integer;
begin
Result := RGBQuadsToPaletteEntries(RGBQuads);
if not AllowPalette256 then
begin
dc := GetDC(0);
GetSystemPaletteEntries(dc, 0, 256, Entries);
ReleaseDC(0, dc);
for i:=0 to 9 do
Result[i] := Entries[i];
for i:=256-10 to 255 do
Result[i] := Entries[i];
end;
for i:=0 to 255 do
Result[i].peFlags := D3DPAL_READONLY;
end;
//Cache絕撈 茄波鍋俊 肺爹竊.
procedure TWMImages.LoadAllData;
var
i: integer;
imgi: TWMImageInfo;
imgiEx: TWMImageInfoEx;
dib: TDIB;
dximg: TDxImage;
begin
dib := TDIB.Create;
for i:=0 to FImageCount-1 do begin
if OldVersionWil then begin
Stream.Read (imgi, sizeof(TWMImageInfo) - 4);
dib.Width := imgi.Width;
dib.Height := imgi.Height;
dib.ColorTable := MainPalette;
dib.UpdatePalette;
Stream.Read (dib.PBits^, imgi.Width * imgi.Height);
dximg.px := imgi.px;
dximg.py := imgi.py;
dximg.surface := TAsphyreImage.Create;
dximg.surface.Quality := aqLow;
dximg.surface.AlphaLevel := alNone;
dximg.surface.PatternSize := Point(imgi.Width, imgi.Height);
dximg.surface.Size := Point(256, 256);//TextureSize;
dximg.surface.VisibleSize := Point(imgi.Width, imgi.Height);
{dximg.surface := TDirectDrawSurface.Create (FDDraw);
dximg.surface.SystemMemory := TRUE;
dximg.surface.SetSize (imgi.Width, imgi.Height);
dximg.surface.Canvas.Draw (0, 0, dib);
dximg.surface.Canvas.Release;}
dib.Clear; //FreeImage;
//dximg.surface.TransparentColor := 0;
ImgArr[i] := dximg;
end else begin
Stream.Read (imgiex, sizeof(TWMImageInfoEx) - 4);
dib.Width := imgiex.Width;
dib.Height := imgiex.Height;
dib.ColorTable := MainPalette;
dib.UpdatePalette;
Stream.Read (dib.PBits^, imgiex.Width * imgiex.Height);
dximg.px := imgiex.px;
dximg.py := imgiex.py;
{dximg.surface := TDirectDrawSurface.Create (FDDraw);
dximg.surface.SystemMemory := TRUE;
dximg.surface.SetSize (imgiex.Width, imgiex.Height);
dximg.surface.Canvas.Draw (0, 0, dib);
dximg.surface.Canvas.Release;}
dib.Clear; //FreeImage;
//dximg.surface.TransparentColor := 0;
ImgArr[i] := dximg;
end;
end;
dib.Free;
end;
procedure TWMImages.LoadPalette;
var
Entries: TPaletteEntries;
begin
if OldVersionWil then
Stream.Seek (sizeof(TWMImageHeader), 0)
else
Stream.Seek (sizeof(TWMImageHeaderEx), 0);
Stream.Read (MainPalette, sizeof(TRgbQuad) * 256); //迫貳飄
//Entries := TDXDrawRGBQuadsToPaletteEntries (MainPalette, TRUE);
//MainSurfacePalette := TDirectDrawPalette.Create (FDDraw);
////MainSurfacePalette.SetEntries(0, 256, Entries);
//MainSurfacePalette.CreatePalette(DDPCAPS_8BIT, Entries);
end;
//Cache絕撈 茄波鍋俊 Bmp肺 肺爹竊.
procedure TWMImages.LoadAllDataBmp;
var
i: integer;
pbuf: PByte;
imgi: TWMImageInfo;
bmp: TBitmap;
begin
{ GetMem (pbuf, 1024*768); //傍儈 滾欺積己, 漂喊茄 撈蠟啊 樂瀾
Stream.Seek (sizeof(TWMImageHeader), 0);
Stream.Read (MainPalette, sizeof(TRgbQuad) * 256); //迫貳飄
for i:=0 to ImageCount-1 do begin
Stream.Read (imgi, sizeof(TWMImageInfo)-4);
Stream.Read (pbuf^, imgi.Width * imgi.Height);
bmp := MakeBmp (imgi.Width, imgi.Height, pbuf, MainPalette);
BmpList.Add (bmp); //BMP府膠飄甫 悼矯俊 包府.. (弊府靛俊 弊府扁儈)
end;
FreeMem (pbuf); }
end;
procedure TWMImages.LoadIndex (idxfile: string);
var
fhandle, i, value: integer;
header: TWMIndexHeader;
headerex: TWMIndexHeaderex;
pidx: PTWMIndexInfo;
pvalue: PInteger;
begin
indexlist.Clear;
if FileExists (idxfile) then begin
fhandle := FileOpen (idxfile, fmOpenRead or fmShareDenyNone);
if fhandle > 0 then begin
if OldVersionWil then begin
FileRead (fhandle, header, sizeof(TWMIndexHeader));
GetMem (pvalue, 4*header.IndexCount);
FileRead (fhandle, pvalue^, 4*header.IndexCount);
for i:=0 to header.IndexCount-1 do begin
new (pidx);
value := PInteger(integer(pvalue) + 4*i)^;
IndexList.Add (pointer(value));
end;
end else begin
FileRead (fhandle, headerex, sizeof(TWMIndexHeaderEx));
GetMem (pvalue, 4*headerex.IndexCount);
FileRead (fhandle, pvalue^, 4*headerex.IndexCount);
for i:=0 to headerex.IndexCount-1 do begin
new (pidx);
value := PInteger(integer(pvalue) + 4*i)^;
IndexList.Add (pointer(value));
end;
end;
FreeMem (pvalue);
FileClose (fhandle);
end;
end;
end;
{----------------- Private Variables ---------------------}
function TWMImages.FGetImageSurface (index: integer): TAsphyreImage;
begin
Result := nil;
if LibType = ltUseCache then begin
Result := GetCachedSurface (index);
end else
if LibType = ltLoadMemory then begin
if (index >= 0) and (index < ImageCount) then
Result := ImgArr[index].Surface;
end;
end;
function TWMImages.FGetImageBitmap (index: integer): TBitmap;
begin
if LibType <> ltLoadBmp then exit;
Result := GetCachedBitmap (index);
{if index in [0..BmpList.Count-1] then begin
Result := TBitmap (BmpList[index]);
end else
Result := nil;}
end;
procedure TWMImages.FSetDxDevice (fdd: TAsphyreDevice);
begin
FDxDevice := fdd;
end;
// *** DirectDrawSurface Functions
procedure TWMImages.LoadDxImage (position: integer; pdximg: PTDxImage);
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -