WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DXDraws.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DXDraws;
		2
		3	interface
		4
		5	{$INCLUDE DelphiXcfg.inc}
		6
		7	uses
		8	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
		9	DXClass, DIB, DXTexImg, DirectX;
		10
		11	type
		12
		13	{ EDirectDrawError }
		14
		15	EDirectDrawError = class(EDirectXError);
		16	EDirectDrawPaletteError = class(EDirectDrawError);
		17	EDirectDrawClipperError = class(EDirectDrawError);
		18	EDirectDrawSurfaceError = class(EDirectDrawError);
		19
		20	{ TDirectDraw }
		21
		22	TDirectDrawClipper = class;
		23	TDirectDrawPalette = class;
		24	TDirectDrawSurface = class;
		25
		26	TDirectDraw = class(TDirectX)
		27	private
		28	FIDDraw: IDirectDraw;
		29	FIDDraw4: IDirectDraw4;
		30	FIDDraw7: IDirectDraw7;
		31	FDriverCaps: TDDCaps;
		32	FHELCaps: TDDCaps;
		33	FClippers: TList;
		34	FPalettes: TList;
		35	FSurfaces: TList;
		36	function GetClipper(Index: Integer): TDirectDrawClipper;
		37	function GetClipperCount: Integer;
		38	function GetDisplayMode: TDDSurfaceDesc;
		39	function GetIDDraw: IDirectDraw;
		40	function GetIDDraw4: IDirectDraw4;
		41	function GetIDDraw7: IDirectDraw7;
		42	function GetIDraw: IDirectDraw;
		43	function GetIDraw4: IDirectDraw4;
		44	function GetIDraw7: IDirectDraw7;
		45	function GetPalette(Index: Integer): TDirectDrawPalette;
		46	function GetPaletteCount: Integer;
		47	function GetSurface(Index: Integer): TDirectDrawSurface;
		48	function GetSurfaceCount: Integer;
		49	public
		50	constructor Create(GUID: PGUID);
		51	constructor CreateEx(GUID: PGUID; DirectX7Mode: Boolean);
		52	destructor Destroy; override;
		53	class function Drivers: TDirectXDrivers;
		54	property ClipperCount: Integer read GetClipperCount;
		55	property Clippers[Index: Integer]: TDirectDrawClipper read GetClipper;
		56	property DisplayMode: TDDSurfaceDesc read GetDisplayMode;
		57	property DriverCaps: TDDCaps read FDriverCaps;
		58	property HELCaps: TDDCaps read FHELCaps;
		59	property IDDraw: IDirectDraw read GetIDDraw;
		60	property IDDraw4: IDirectDraw4 read GetIDDraw4;
		61	property IDDraw7: IDirectDraw7 read GetIDDraw7;
		62	property IDraw: IDirectDraw read GetIDraw;
		63	property IDraw4: IDirectDraw4 read GetIDraw4;
		64	property IDraw7: IDirectDraw7 read GetIDraw7;
		65	property PaletteCount: Integer read GetPaletteCount;
		66	property Palettes[Index: Integer]: TDirectDrawPalette read GetPalette;
		67	property SurfaceCount: Integer read GetSurfaceCount;
		68	property Surfaces[Index: Integer]: TDirectDrawSurface read GetSurface;
		69	end;
		70
		71	{ TDirectDrawClipper }
		72
		73	TDirectDrawClipper = class(TDirectX)
		74	private
		75	FDDraw: TDirectDraw;
		76	FIDDClipper: IDirectDrawClipper;
		77	function GetIDDClipper: IDirectDrawClipper;
		78	function GetIClipper: IDirectDrawClipper;
		79	procedure SetHandle(Value: THandle);
		80	procedure SetIDDClipper(Value: IDirectDrawClipper);
		81	property Handle: THandle write SetHandle;
		82	public
		83	constructor Create(ADirectDraw: TDirectDraw);
		84	destructor Destroy; override;
		85	procedure SetClipRects(const Rects: array of TRect);
		86	property DDraw: TDirectDraw read FDDraw;
		87	property IClipper: IDirectDrawClipper read GetIClipper;
		88	property IDDClipper: IDirectDrawClipper read GetIDDClipper write SetIDDClipper;
		89	end;
		90
		91	{ TDirectDrawPalette }
		92
		93	TDirectDrawPalette = class(TDirectX)
		94	private
		95	FDDraw: TDirectDraw;
		96	FIDDPalette: IDirectDrawPalette;
		97	function GetEntry(Index: Integer): TPaletteEntry;
		98	function GetIDDPalette: IDirectDrawPalette;
		99	function GetIPalette: IDirectDrawPalette;
		100	procedure SetEntry(Index: Integer; Value: TPaletteEntry);
		101	procedure SetIDDPalette(Value: IDirectDrawPalette);
		102	public
		103	constructor Create(ADirectDraw: TDirectDraw);
		104	destructor Destroy; override;
		105	function CreatePalette(Caps: DWORD; const Entries): Boolean;
		106	function GetEntries(StartIndex, NumEntries: Integer; var Entries): Boolean;
		107	procedure LoadFromDIB(DIB: TDIB);
		108	procedure LoadFromFile(const FileName: string);
		109	procedure LoadFromStream(Stream: TStream);
		110	function SetEntries(StartIndex, NumEntries: Integer; const Entries): Boolean;
		111	property DDraw: TDirectDraw read FDDraw;
		112	property Entries[Index: Integer]: TPaletteEntry read GetEntry write SetEntry;
		113	property IDDPalette: IDirectDrawPalette read GetIDDPalette write SetIDDPalette;
		114	property IPalette: IDirectDrawPalette read GetIPalette;
		115	end;
		116
		117	{ TDirectDrawSurfaceCanvas }
		118
		119	TDirectDrawSurfaceCanvas = class(TCanvas)
		120	private
		121	FDC: HDC;
		122	FSurface: TDirectDrawSurface;
		123	protected
		124	procedure CreateHandle; override;
		125	public
		126	constructor Create(ASurface: TDirectDrawSurface);
		127	destructor Destroy; override;
		128	procedure Release;
		129	end;
		130
		131	{ TDirectDrawSurface }
		132
		133	TDirectDrawSurface = class(TDirectX)
		134	private
		135	FCanvas: TDirectDrawSurfaceCanvas;
		136	FHasClipper: Boolean;
		137	FDDraw: TDirectDraw;
		138	FIDDSurface: IDirectDrawSurface;
		139	FIDDSurface4: IDirectDrawSurface4;
		140	FIDDSurface7: IDirectDrawSurface7;
		141	FSystemMemory: Boolean;
		142	FStretchDrawClipper: IDirectDrawClipper;
		143	FSurfaceDesc: TDDSurfaceDesc;
		144	FGammaControl: IDirectDrawGammaControl;
		145	FLockSurfaceDesc: TDDSurfaceDesc;
		146	FLockCount: Integer;
		147	function GetBitCount: Integer;
		148	function GetCanvas: TDirectDrawSurfaceCanvas;
		149	function GetClientRect: TRect;
		150	function GetHeight: Integer;
		151	function GetIDDSurface: IDirectDrawSurface;
		152	function GetIDDSurface4: IDirectDrawSurface4;
		153	function GetIDDSurface7: IDirectDrawSurface7;
		154	function GetISurface: IDirectDrawSurface;
		155	function GetISurface4: IDirectDrawSurface4;
		156	function GetISurface7: IDirectDrawSurface7;
		157	function GetPixel(X, Y: Integer): Longint;
		158	function GetWidth: Integer;
		159	procedure SetClipper(Value: TDirectDrawClipper);
		160	procedure SetColorKey(Flags: DWORD; const Value: TDDColorKey);
		161	procedure SetIDDSurface(Value: IDirectDrawSurface);
		162	procedure SetIDDSurface4(Value: IDirectDrawSurface4);
		163	procedure SetIDDSurface7(Value: IDirectDrawSurface7);
		164	procedure SetPalette(Value: TDirectDrawPalette);
		165	procedure SetPixel(X, Y: Integer; Value: Longint);
		166	procedure SetTransparentColor(Col: Longint);
		167	public
		168	constructor Create(ADirectDraw: TDirectDraw);
		169	destructor Destroy; override;
		170	procedure Assign(Source: TPersistent); override;
		171	procedure AssignTo(Dest: TPersistent); override;
		172	function Blt(const DestRect, SrcRect: TRect; Flags: DWORD;
		173	const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean;
		174	function BltFast(X, Y: Integer; const SrcRect: TRect;
		175	Flags: DWORD; Source: TDirectDrawSurface): Boolean;
		176	function ColorMatch(Col: TColor): Integer;
		177	{$IFDEF DelphiX_Spt4}
		178	function CreateSurface(const SurfaceDesc: TDDSurfaceDesc): Boolean; overload;
		179	function CreateSurface(const SurfaceDesc: TDDSurfaceDesc2): Boolean; overload;
		180	{$ELSE}
		181	function CreateSurface(const SurfaceDesc: TDDSurfaceDesc): Boolean;
		182	{$ENDIF}
		183	{$IFDEF DelphiX_Spt4}
		184	procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean=True); overload;
		185	procedure Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean=True); overload;
		186	procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		187	Transparent: Boolean=True); overload;
		188	procedure StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
		189	Transparent: Boolean=True); overload;
		190	{$ELSE}
		191	procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
		192	Transparent: Boolean);
		193	procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		194	Transparent: Boolean);
		195	{$ENDIF}
		196	procedure DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		197	Transparent: Boolean; Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		198	procedure DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		199	Transparent: Boolean; Alpha: Integer);
		200	procedure DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		201	Transparent: Boolean; Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		202	procedure DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
		203	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer);
		204	procedure DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
		205	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
		206	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		207	procedure DrawRotateAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
		208	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
		209	Alpha: Integer);
		210	procedure DrawRotateSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
		211	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
		212	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		213	procedure DrawWaveX(X, Y, Width, Height: Integer; const SrcRect: TRect;
		214	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
		215	procedure DrawWaveXAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
		216	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
		217	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		218	procedure DrawWaveXAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
		219	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
		220	Alpha: Integer);
		221	procedure DrawWaveXSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
		222	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
		223	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		224	procedure Fill(DevColor: Longint);
		225	procedure FillRect(const Rect: TRect; DevColor: Longint);
		226	procedure FillRectAdd(const DestRect: TRect; Color: TColor);
		227	procedure FillRectAlpha(const DestRect: TRect; Color: TColor; Alpha: Integer);
		228	procedure FillRectSub(const DestRect: TRect; Color: TColor);
		229	procedure LoadFromDIB(DIB: TDIB);
		230	procedure LoadFromDIBRect(DIB: TDIB; AWidth, AHeight: Integer; const SrcRect: TRect);
		231	procedure LoadFromGraphic(Graphic: TGraphic);
		232	procedure LoadFromGraphicRect(Graphic: TGraphic; AWidth, AHeight: Integer; const SrcRect: TRect);
		233	procedure LoadFromFile(const FileName: string);
		234	procedure LoadFromStream(Stream: TStream);
		235	{$IFDEF DelphiX_Spt4}
		236	function Lock(const Rect: TRect; var SurfaceDesc: TDDSurfaceDesc): Boolean; overload;
		237	function Lock(var SurfaceDesc: TDDSurfaceDesc): Boolean; overload;
		238	{$ELSE}
		239	function Lock(const Rect: TRect; var SurfaceDesc: TDDSurfaceDesc): Boolean;
		240	{$ENDIF}
		241	procedure UnLock;
		242	function Restore: Boolean;
		243	procedure SetSize(AWidth, AHeight: Integer);
		244	property BitCount: Integer read GetBitCount;
		245	property Canvas: TDirectDrawSurfaceCanvas read GetCanvas;
		246	property ClientRect: TRect read GetClientRect;
		247	property Clipper: TDirectDrawClipper write SetClipper;
		248	property ColorKey[Flags: DWORD]: TDDColorKey write SetColorKey;
		249	property DDraw: TDirectDraw read FDDraw;
		250	property GammaControl: IDirectDrawGammaControl read FGammaControl;
		251	property Height: Integer read GetHeight;
		252	property IDDSurface: IDirectDrawSurface read GetIDDSurface write SetIDDSurface;
		253	property IDDSurface4: IDirectDrawSurface4 read GetIDDSurface4 write SetIDDSurface4;
		254	property IDDSurface7: IDirectDrawSurface7 read GetIDDSurface7 write SetIDDSurface7;
		255	property ISurface: IDirectDrawSurface read GetISurface;
		256	property ISurface4: IDirectDrawSurface4 read GetISurface4;
		257	property ISurface7: IDirectDrawSurface7 read GetISurface7;
		258	property Palette: TDirectDrawPalette write SetPalette;
		259	property Pixels[X, Y: Integer]: Longint read GetPixel write SetPixel;
		260	property SurfaceDesc: TDDSurfaceDesc read FSurfaceDesc;
		261	property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
		262	property TransparentColor: Longint write SetTransparentColor;
		263	property Width: Integer read GetWidth;
		264	end;
		265
		266	{ TDXDrawDisplay }
		267
		268	TCustomDXDraw = class;
		269
		270	TDXDrawDisplayMode = class(TCollectionItem)
		271	private
		272	FSurfaceDesc: TDDSurfaceDesc;
		273	function GetBitCount: Integer;
		274	function GetHeight: Integer;
		275	function GetWidth: Integer;
		276	public
		277	property BitCount: Integer read GetBitCount;
		278	property Height: Integer read GetHeight;
		279	property SurfaceDesc: TDDSurfaceDesc read FSurfaceDesc;
		280	property Width: Integer read GetWidth;
		281	end;
		282
		283	TDXDrawDisplay = class(TPersistent)
		284	private
		285	FBitCount: Integer;
		286	FDXDraw: TCustomDXDraw;
		287	FHeight: Integer;
		288	FModes: TCollection;
		289	FWidth: Integer;
		290	FFixedBitCount: Boolean;
		291	FFixedRatio: Boolean;
		292	FFixedSize: Boolean;
		293	function GetCount: Integer;
		294	function GetMode: TDXDrawDisplayMode;
		295	function GetMode2(Index: Integer): TDXDrawDisplayMode;
		296	procedure LoadDisplayModes;
		297	procedure SetBitCount(Value: Integer);
		298	procedure SetHeight(Value: Integer);
		299	procedure SetWidth(Value: Integer);
		300	function SetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
		301	function DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
		302	public
		303	constructor Create(ADXDraw: TCustomDXDraw);
		304	destructor Destroy; override;
		305	procedure Assign(Source: TPersistent); override;
		306	function IndexOf(Width, Height, BitCount: Integer): Integer;
		307	property Count: Integer read GetCount;
		308	property Mode: TDXDrawDisplayMode read GetMode;
		309	property Modes[Index: Integer]: TDXDrawDisplayMode read GetMode2; default;
		310	published
		311	property BitCount: Integer read FBitCount write SetBitCount default 8;
		312	property FixedBitCount: Boolean read FFixedBitCount write FFixedBitCount;
		313	property FixedRatio: Boolean read FFixedRatio write FFixedRatio;
		314	property FixedSize: Boolean read FFixedSize write FFixedSize;
		315	property Height: Integer read FHeight write SetHeight default 480;
		316	property Width: Integer read FWidth write SetWidth default 640;
		317	end;
		318
		319	TDirectDrawDisplay = TDXDrawDisplay;
		320	TDirectDrawDisplayMode = TDXDrawDisplayMode;
		321
		322	{ EDXDrawError }
		323
		324	EDXDrawError = class(Exception);
		325
		326	{ TCustomDXDraw }
		327
		328	TDXDrawOption = (doFullScreen, doNoWindowChange, doAllowReboot, doWaitVBlank,
		329	doAllowPalette256, doSystemMemory, doStretch, doCenter, doFlip,
		330	do3D, doDirectX7Mode, doRetainedMode, doHardware, doSelectDriver, doZBuffer);
		331
		332	TDXDrawOptions = set of TDXDrawOption;
		333
		334	TDXDrawNotifyType = (dxntDestroying, dxntInitializing, dxntInitialize, dxntInitializeSurface,
		335	dxntFinalize, dxntFinalizeSurface, dxntRestore, dxntSetSurfaceSize);
		336
		337	TDXDrawNotifyEvent = procedure(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType) of object;
		338
		339	TCustomDXDraw = class(TCustomControl)
		340	private
		341	FAutoInitialize: Boolean;
		342	FAutoSize: Boolean;
		343	FCalledDoInitialize: Boolean;
		344	FCalledDoInitializeSurface: Boolean;
		345	FForm: TCustomForm;
		346	FNotifyEventList: TList;
		347	FInitialized: Boolean;
		348	FInitialized2: Boolean;
		349	FInternalInitialized: Boolean;
		350	FUpdating: Boolean;
		351	FSubClass: TControlSubClass;
		352	FNowOptions: TDXDrawOptions;
		353	FOptions: TDXDrawOptions;
		354	FOnFinalize: TNotifyEvent;
		355	FOnFinalizeSurface: TNotifyEvent;
		356	FOnInitialize: TNotifyEvent;
		357	FOnInitializeSurface: TNotifyEvent;
		358	FOnInitializing: TNotifyEvent;
		359	FOnRestoreSurface: TNotifyEvent;
		360	FOffNotifyRestore: Integer;
		361	{ DirectDraw }
		362	FDXDrawDriver: TObject;
		363	FDriver: PGUID;
		364	FDriverGUID: TGUID;
		365	FDDraw: TDirectDraw;
		366	FDisplay: TDXDrawDisplay;
		367	FClipper: TDirectDrawClipper;
		368	FPalette: TDirectDrawPalette;
		369	FPrimary: TDirectDrawSurface;
		370	FSurface: TDirectDrawSurface;
		371	FSurfaceWidth: Integer;
		372	FSurfaceHeight: Integer;
		373	{ Direct3D }
		374	FD3D: IDirect3D;
		375	FD3D2: IDirect3D2;
		376	FD3D3: IDirect3D3;
		377	FD3D7: IDirect3D7;
		378	FD3DDevice: IDirect3DDevice;
		379	FD3DDevice2: IDirect3DDevice2;
		380	FD3DDevice3: IDirect3DDevice3;
		381	FD3DDevice7: IDirect3DDevice7;
		382	FD3DRM: IDirect3DRM;
		383	FD3DRM2: IDirect3DRM2;
		384	FD3DRM3: IDirect3DRM3;
		385	FD3DRMDevice: IDirect3DRMDevice;
		386	FD3DRMDevice2: IDirect3DRMDevice2;
		387	FD3DRMDevice3: IDirect3DRMDevice3;
		388	FCamera: IDirect3DRMFrame;
		389	FScene: IDirect3DRMFrame;
		390	FViewport: IDirect3DRMViewport;
		391	FZBuffer: TDirectDrawSurface;
		392	procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
		393	function GetCanDraw: Boolean;
		394	function GetCanPaletteAnimation: Boolean;
		395	function GetSurfaceHeight: Integer;
		396	function GetSurfaceWidth: Integer;
		397	procedure NotifyEventList(NotifyType: TDXDrawNotifyType);
		398	procedure SetAutoSize(Value: Boolean);
		399	procedure SetColorTable(const ColorTable: TRGBQuads);
		400	procedure SetCooperativeLevel;
		401	procedure SetDisplay(Value: TDXDrawDisplay);
		402	procedure SetDriver(Value: PGUID);
		403	procedure SetOptions(Value: TDXDrawOptions);
		404	procedure SetSurfaceHeight(Value: Integer);
		405	procedure SetSurfaceWidth(Value: Integer);
		406	function TryRestore: Boolean;
		407	procedure WMCreate(var Message: TMessage); message WM_CREATE;
		408	protected
		409	procedure DoFinalize; virtual;
		410	procedure DoFinalizeSurface; virtual;
		411	procedure DoInitialize; virtual;
		412	procedure DoInitializeSurface; virtual;
		413	procedure DoInitializing; virtual;
		414	procedure DoRestoreSurface; virtual;
		415	procedure Loaded; override;
		416	procedure Paint; override;
		417	function PaletteChanged(Foreground: Boolean): Boolean; override;
		418	procedure SetParent(AParent: TWinControl); override;
		419	public
		420	ColorTable: TRGBQuads;
		421	DefColorTable: TRGBQuads;
		422	constructor Create(AOwner: TComponent); override;
		423	destructor Destroy; override;
		424	class function Drivers: TDirectXDrivers;
		425	procedure Finalize;
		426	procedure Flip;
		427	procedure Initialize;
		428	procedure Render;
		429	procedure Restore;
		430	procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
		431	procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
		432	procedure UpdatePalette;
		433	procedure RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
		434	procedure UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
		435
		436	property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
		437	property AutoSize: Boolean read FAutoSize write SetAutoSize;
		438	property Camera: IDirect3DRMFrame read FCamera;
		439	property CanDraw: Boolean read GetCanDraw;
		440	property CanPaletteAnimation: Boolean read GetCanPaletteAnimation;
		441	property Clipper: TDirectDrawClipper read FClipper;
		442	property Color;
		443	property D3D: IDirect3D read FD3D;
		444	property D3D2: IDirect3D2 read FD3D2;
		445	property D3D3: IDirect3D3 read FD3D3;
		446	property D3D7: IDirect3D7 read FD3D7;
		447	property D3DDevice: IDirect3DDevice read FD3DDevice;
		448	property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
		449	property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
		450	property D3DDevice7: IDirect3DDevice7 read FD3DDevice7;
		451	property D3DRM: IDirect3DRM read FD3DRM;
		452	property D3DRM2: IDirect3DRM2 read FD3DRM2;
		453	property D3DRM3: IDirect3DRM3 read FD3DRM3;
		454	property D3DRMDevice: IDirect3DRMDevice read FD3DRMDevice;
		455	property D3DRMDevice2: IDirect3DRMDevice2 read FD3DRMDevice2;
		456	property D3DRMDevice3: IDirect3DRMDevice3 read FD3DRMDevice3;
		457	property DDraw: TDirectDraw read FDDraw;
		458	property Display: TDXDrawDisplay read FDisplay write SetDisplay;
		459	property Driver: PGUID read FDriver write SetDriver;
		460	property Initialized: Boolean read FInitialized;
		461	property NowOptions: TDXDrawOptions read FNowOptions;
		462	property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
		463	property OnFinalizeSurface: TNotifyEvent read FOnFinalizeSurface write FOnFinalizeSurface;
		464	property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
		465	property OnInitializeSurface: TNotifyEvent read FOnInitializeSurface write FOnInitializeSurface;
		466	property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
		467	property OnRestoreSurface: TNotifyEvent read FOnRestoreSurface write FOnRestoreSurface;
		468	property Options: TDXDrawOptions read FOptions write SetOptions;
		469	property Palette: TDirectDrawPalette read FPalette;
		470	property Primary: TDirectDrawSurface read FPrimary;
		471	property Scene: IDirect3DRMFrame read FScene;
		472	property Surface: TDirectDrawSurface read FSurface;
		473	property SurfaceHeight: Integer read GetSurfaceHeight write SetSurfaceHeight default 480;
		474	property SurfaceWidth: Integer read GetSurfaceWidth write SetSurfaceWidth default 640;
		475	property Viewport: IDirect3DRMViewport read FViewport;
		476	property ZBuffer: TDirectDrawSurface read FZBuffer;
		477	end;
		478
		479	{ TDXDraw }
		480
		481	TDXDraw = class(TCustomDXDraw)
		482	published
		483	property AutoInitialize;
		484	property AutoSize;
		485	property Color;
		486	property Display;
		487	property Options;
		488	property SurfaceHeight;
		489	property SurfaceWidth;
		490	property OnFinalize;
		491	property OnFinalizeSurface;
		492	property OnInitialize;
		493	property OnInitializeSurface;
		494	property OnInitializing;
		495	property OnRestoreSurface;
		496
		497	property Align;
		498	{$IFDEF DelphiX_Spt4}property Anchors;{$ENDIF}
		499	{$IFDEF DelphiX_Spt4}property Constraints;{$ENDIF}
		500	property DragCursor;
		501	property DragMode;
		502	property Enabled;
		503	property ParentShowHint;
		504	property PopupMenu;
		505	property ShowHint;
		506	property TabOrder;
		507	property TabStop;
		508	property Visible;
		509	property OnClick;
		510	property OnDblClick;
		511	property OnDragDrop;
		512	property OnDragOver;
		513	property OnEndDrag;
		514	property OnEnter;
		515	property OnExit;
		516	property OnKeyDown;
		517	property OnKeyPress;
		518	property OnKeyUp;
		519	property OnMouseDown;
		520	property OnMouseMove;
		521	property OnMouseUp;
		522	{$IFDEF DelphiX_Spt4}property OnResize;{$ENDIF}
		523	property OnStartDrag;
		524	end;
		525
		526	{ EDX3DError }
		527
		528	EDX3DError = class(Exception);
		529
		530	{ TCustomDX3D }
		531
		532	TDX3DOption = (toRetainedMode, toSystemMemory, toHardware, toSelectDriver, toZBuffer);
		533
		534	TDX3DOptions = set of TDX3DOption;
		535
		536	TCustomDX3D = class(TComponent)
		537	private
		538	FAutoSize: Boolean;
		539	FCamera: IDirect3DRMFrame;
		540	FD3D: IDirect3D;
		541	FD3D2: IDirect3D2;
		542	FD3D3: IDirect3D3;
		543	FD3D7: IDirect3D7;
		544	FD3DDevice: IDirect3DDevice;
		545	FD3DDevice2: IDirect3DDevice2;
		546	FD3DDevice3: IDirect3DDevice3;
		547	FD3DDevice7: IDirect3DDevice7;
		548	FD3DRM: IDirect3DRM;
		549	FD3DRM2: IDirect3DRM2;
		550	FD3DRM3: IDirect3DRM3;
		551	FD3DRMDevice: IDirect3DRMDevice;
		552	FD3DRMDevice2: IDirect3DRMDevice2;
		553	FD3DRMDevice3: IDirect3DRMDevice3;
		554	FDXDraw: TCustomDXDraw;
		555	FInitFlag: Boolean;
		556	FInitialized: Boolean;
		557	FNowOptions: TDX3DOptions;
		558	FOnFinalize: TNotifyEvent;
		559	FOnInitialize: TNotifyEvent;
		560	FOptions: TDX3DOptions;
		561	FScene: IDirect3DRMFrame;
		562	FSurface: TDirectDrawSurface;
		563	FSurfaceHeight: Integer;
		564	FSurfaceWidth: Integer;
		565	FViewport: IDirect3DRMViewport;
		566	FZBuffer: TDirectDrawSurface;
		567	procedure Finalize;
		568	procedure Initialize;
		569	procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
		570	function GetCanDraw: Boolean;
		571	function GetSurfaceHeight: Integer;
		572	function GetSurfaceWidth: Integer;
		573	procedure SetAutoSize(Value: Boolean);
		574	procedure SetDXDraw(Value: TCustomDXDraw);
		575	procedure SetOptions(Value: TDX3DOptions);
		576	procedure SetSurfaceHeight(Value: Integer);
		577	procedure SetSurfaceWidth(Value: Integer);
		578	protected
		579	procedure DoFinalize; virtual;
		580	procedure DoInitialize; virtual;
		581	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
		582	public
		583	constructor Create(AOwner: TComponent); override;
		584	destructor Destroy; override;
		585	procedure Render;
		586	procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
		587	property AutoSize: Boolean read FAutoSize write SetAutoSize;
		588	property Camera: IDirect3DRMFrame read FCamera;
		589	property CanDraw: Boolean read GetCanDraw;
		590	property D3D: IDirect3D read FD3D;
		591	property D3D2: IDirect3D2 read FD3D2;
		592	property D3D3: IDirect3D3 read FD3D3;
		593	property D3D7: IDirect3D7 read FD3D7;
		594	property D3DDevice: IDirect3DDevice read FD3DDevice;
		595	property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
		596	property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
		597	property D3DDevice7: IDirect3DDevice7 read FD3DDevice7;
		598	property D3DRM: IDirect3DRM read FD3DRM;
		599	property D3DRM2: IDirect3DRM2 read FD3DRM2;
		600	property D3DRM3: IDirect3DRM3 read FD3DRM3;
		601	property D3DRMDevice: IDirect3DRMDevice read FD3DRMDevice;
		602	property D3DRMDevice2: IDirect3DRMDevice2 read FD3DRMDevice2;
		603	property D3DRMDevice3: IDirect3DRMDevice3 read FD3DRMDevice3;
		604	property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
		605	property Initialized: Boolean read FInitialized;
		606	property NowOptions: TDX3DOptions read FNowOptions;
		607	property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
		608	property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
		609	property Options: TDX3DOptions read FOptions write SetOptions;
		610	property Scene: IDirect3DRMFrame read FScene;
		611	property Surface: TDirectDrawSurface read FSurface;
		612	property SurfaceHeight: Integer read GetSurfaceHeight write SetSurfaceHeight default 480;
		613	property SurfaceWidth: Integer read GetSurfaceWidth write SetSurfaceWidth default 640;
		614	property Viewport: IDirect3DRMViewport read FViewport;
		615	property ZBuffer: TDirectDrawSurface read FZBuffer;
		616	end;
		617
		618	{ TDX3D }
		619
		620	TDX3D = class(TCustomDX3D)
		621	published
		622	property AutoSize;
		623	property DXDraw;
		624	property Options;
		625	property SurfaceHeight;
		626	property SurfaceWidth;
		627	property OnFinalize;
		628	property OnInitialize;
		629	end;
		630
		631	{ EDirect3DTextureError }
		632
		633	EDirect3DTextureError = class(Exception);
		634
		635	{ TDirect3DTexture }
		636
		637	TDirect3DTexture = class
		638	private
		639	FBitCount: DWORD;
		640	FDXDraw: TComponent;
		641	FEnumFormatFlag: Boolean;
		642	FFormat: TDDSurfaceDesc;
		643	FGraphic: TGraphic;
		644	FHandle: TD3DTextureHandle;
		645	FPaletteEntries: TPaletteEntries;
		646	FSurface: TDirectDrawSurface;
		647	FTexture: IDirect3DTexture;
		648	FTransparentColor: TColor;
		649	procedure Clear;
		650	procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
		651	function GetHandle: TD3DTextureHandle;
		652	function GetSurface: TDirectDrawSurface;
		653	function GetTexture: IDirect3DTexture;
		654	procedure SetTransparentColor(Value: TColor);
		655	public
		656	constructor Create(Graphic: TGraphic; DXDraw: TComponent);
		657	destructor Destroy; override;
		658	procedure Restore;
		659	property Handle: TD3DTextureHandle read GetHandle;
		660	property Surface: TDirectDrawSurface read GetSurface;
		661	property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
		662	property Texture: IDirect3DTexture read GetTexture;
		663	end;
		664
		665	{ TDirect3DTexture2 }
		666
		667	TDirect3DTexture2 = class
		668	private
		669	FDXDraw: TCustomDXDraw;
		670	FSrcImage: TObject;
		671	FImage: TDXTextureImage;
		672	FImage2: TDXTextureImage;
		673	FAutoFreeGraphic: Boolean;
		674	FSurface: TDirectDrawSurface;
		675	FTextureFormat: TDDSurfaceDesc2;
		676	FMipmap: Boolean;
		677	FTransparent: Boolean;
		678	FTransparentColor: TColorRef;
		679	FUseMipmap: Boolean;
		680	FUseColorKey: Boolean;
		681	FOnRestoreSurface: TNotifyEvent;
		682	FNeedLoadTexture: Boolean;
		683	FEnumTextureFormatFlag: Boolean;
		684	FD3DDevDesc: TD3DDeviceDesc;
		685	procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
		686	procedure SetDXDraw(ADXDraw: TCustomDXDraw);
		687	procedure LoadSubTexture(Dest: IDirectDrawSurface4; SrcImage: TDXTextureImage);
		688	procedure SetColorKey;
		689	procedure SetDIB(DIB: TDIB);
		690	function GetIsMipmap: Boolean;
		691	function GetSurface: TDirectDrawSurface;
		692	function GetTransparent: Boolean;
		693	procedure SetTransparent(Value: Boolean);
		694	procedure SetTransparentColor(Value: TColorRef);
		695	protected
		696	procedure DoRestoreSurface; virtual;
		697	public
		698	constructor Create(ADXDraw: TCustomDXDraw; Graphic: TObject; AutoFreeGraphic: Boolean);
		699	constructor CreateFromFile(ADXDraw: TCustomDXDraw; const FileName: string);
		700	constructor CreateVideoTexture(ADXDraw: TCustomDXDraw);
		701	destructor Destroy; override;
		702	procedure Finalize;
		703	procedure Load;
		704	procedure Initialize;
		705	property IsMipmap: Boolean read GetIsMipmap;
		706	property Surface: TDirectDrawSurface read GetSurface;
		707	property TextureFormat: TDDSurfaceDesc2 read FTextureFormat write FTextureFormat;
		708	property Transparent: Boolean read GetTransparent write SetTransparent;
		709	property TransparentColor: TColorRef read FTransparentColor write SetTransparentColor;
		710	property OnRestoreSurface: TNotifyEvent read FOnRestoreSurface write FOnRestoreSurface;
		711	end;
		712
		713	{ EDirect3DRMUserVisualError }
		714
		715	EDirect3DRMUserVisualError = class(Exception);
		716
		717	{ TDirect3DRMUserVisual }
		718
		719	TDirect3DRMUserVisual = class
		720	private
		721	FUserVisual: IDirect3DRMUserVisual;
		722	protected
		723	function DoRender(Reason: TD3DRMUserVisualReason;
		724	D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT; virtual;
		725	public
		726	constructor Create(D3DRM: IDirect3DRM);
		727	destructor Destroy; override;
		728	property UserVisual: IDirect3DRMUserVisual read FUserVisual;
		729	end;
		730
		731	{ EPictureCollectionError }
		732
		733	EPictureCollectionError = class(Exception);
		734
		735	{ TPictureCollectionItem }
		736
		737	TPictureCollection = class;
		738
		739	TPictureCollectionItem = class(THashCollectionItem)
		740	private
		741	FPicture: TPicture;
		742	FInitialized: Boolean;
		743	FPatternHeight: Integer;
		744	FPatternWidth: Integer;
		745	FPatterns: TCollection;
		746	FSkipHeight: Integer;
		747	FSkipWidth: Integer;
		748	FSurfaceList: TList;
		749	FSystemMemory: Boolean;
		750	FTransparent: Boolean;
		751	FTransparentColor: TColor;
		752	procedure ClearSurface;
		753	procedure Finalize;
		754	procedure Initialize;
		755	function GetHeight: Integer;
		756	function GetPictureCollection: TPictureCollection;
		757	function GetPatternRect(Index: Integer): TRect;
		758	function GetPatternSurface(Index: Integer): TDirectDrawSurface;
		759	function GetPatternCount: Integer;
		760	function GetWidth: Integer;
		761	procedure SetPicture(Value: TPicture);
		762	procedure SetTransparentColor(Value: TColor);
		763	public
		764	constructor Create(Collection: TCollection); override;
		765	destructor Destroy; override;
		766	procedure Assign(Source: TPersistent); override;
		767	procedure Draw(Dest: TDirectDrawSurface; X, Y: Integer; PatternIndex: Integer);
		768	procedure StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
		769	procedure DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
		770	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		771	procedure DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
		772	Alpha: Integer);
		773	procedure DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
		774	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		775	procedure DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		776	CenterX, CenterY: Double; Angle: Integer);
		777	procedure DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		778	CenterX, CenterY: Double; Angle: Integer;
		779	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		780	procedure DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		781	CenterX, CenterY: Double; Angle: Integer;
		782	Alpha: Integer);
		783	procedure DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		784	CenterX, CenterY: Double; Angle: Integer;
		785	Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		786	procedure DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		787	amp, Len, ph: Integer);
		788	procedure DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		789	amp, Len, ph: Integer; Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		790	procedure DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		791	amp, Len, ph: Integer; Alpha: Integer);
		792	procedure DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height: Integer; PatternIndex: Integer;
		793	amp, Len, ph: Integer; Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
		794	procedure Restore;
		795	property Height: Integer read GetHeight;
		796	property Initialized: Boolean read FInitialized;
		797	property PictureCollection: TPictureCollection read GetPictureCollection;
		798	property PatternCount: Integer read GetPatternCount;
		799	property PatternRects[Index: Integer]: TRect read GetPatternRect;
		800	property PatternSurfaces[Index: Integer]: TDirectDrawSurface read GetPatternSurface;
		801	property Width: Integer read GetWidth;
		802	published
		803	property PatternHeight: Integer read FPatternHeight write FPatternHeight;
		804	property PatternWidth: Integer read FPatternWidth write FPatternWidth;
		805	property Picture: TPicture read FPicture write SetPicture;
		806	property SkipHeight: Integer read FSkipHeight write FSkipHeight default 0;
		807	property SkipWidth: Integer read FSkipWidth write FSkipWidth default 0;
		808	property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
		809	property Transparent: Boolean read FTransparent write FTransparent;
		810	property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
		811	end;
		812
		813	{ TPictureCollection }
		814
		815	TPictureCollection = class(THashCollection)
		816	private
		817	FDXDraw: TCustomDXDraw;
		818	FOwner: TPersistent;
		819	function GetItem(Index: Integer): TPictureCollectionItem;
		820	procedure ReadColorTable(Stream: TStream);
		821	procedure WriteColorTable(Stream: TStream);
		822	function Initialized: Boolean;
		823	protected
		824	procedure DefineProperties(Filer: TFiler); override;
		825	function GetOwner: TPersistent; override;
		826	public
		827	ColorTable: TRGBQuads;
		828	constructor Create(AOwner: TPersistent);
		829	destructor Destroy; override;
		830	function Find(const Name: string): TPictureCollectionItem;
		831	procedure Finalize;
		832	procedure Initialize(DXDraw: TCustomDXDraw);
		833	procedure LoadFromFile(const FileName: string);
		834	procedure LoadFromStream(Stream: TStream);
		835	procedure MakeColorTable;
		836	procedure Restore;
		837	procedure SaveToFile(const FileName: string);
		838	procedure SaveToStream(Stream: TStream);
		839	property DXDraw: TCustomDXDraw read FDXDraw;
		840	property Items[Index: Integer]: TPictureCollectionItem read GetItem; default;
		841	end;
		842
		843	{ TCustomDXImageList }
		844
		845	TCustomDXImageList = class(TComponent)
		846	private
		847	FDXDraw: TCustomDXDraw;
		848	FItems: TPictureCollection;
		849	procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
		850	procedure SetDXDraw(Value: TCustomDXDraw);
		851	procedure SetItems(Value: TPictureCollection);
		852	protected
		853	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
		854	public
		855	constructor Create(AOnwer: TComponent); override;
		856	destructor Destroy; override;
		857	property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
		858	property Items: TPictureCollection read FItems write SetItems;
		859	end;
		860
		861	{ TDXImageList }
		862
		863	TDXImageList = class(TCustomDXImageList)
		864	published
		865	property DXDraw;
		866	property Items;
		867	end;
		868
		869	{ EDirectDrawOverlayError }
		870
		871	EDirectDrawOverlayError = class(Exception);
		872
		873	{ TDirectDrawOverlay }
		874
		875	TDirectDrawOverlay = class
		876	private
		877	FDDraw: TDirectDraw;
		878	FTargetSurface: TDirectDrawSurface;
		879	FDDraw2: TDirectDraw;
		880	FTargetSurface2: TDirectDrawSurface;
		881	FSurface: TDirectDrawSurface;
		882	FBackSurface: TDirectDrawSurface;
		883	FOverlayColorKey: TColor;
		884	FOverlayRect: TRect;
		885	FVisible: Boolean;
		886	procedure SetOverlayColorKey(Value: TColor);
		887	procedure SetOverlayRect(const Value: TRect);
		888	procedure SetVisible(Value: Boolean);
		889	public
		890	constructor Create(DDraw: TDirectDraw; TargetSurface: TDirectDrawSurface);
		891	constructor CreateWindowed(WindowHandle: HWND);
		892	destructor Destroy; override;
		893	procedure Finalize;
		894	procedure Initialize(const SurfaceDesc: TDDSurfaceDesc);
		895	procedure Flip;
		896	property OverlayColorKey: TColor read FOverlayColorKey write SetOverlayColorKey;
		897	property OverlayRect: TRect read FOverlayRect write SetOverlayRect;
		898	property Surface: TDirectDrawSurface read FSurface;
		899	property BackSurface: TDirectDrawSurface read FBackSurface;
		900	property Visible: Boolean read FVisible write SetVisible;
		901	end;
		902
		903	implementation
		904
		905	uses DXConsts, DXRender;
		906
		907	function DXDirectDrawEnumerate(lpCallback: TDDEnumCallbackA;
		908	lpContext: Pointer): HRESULT;
		909	type
		910	TDirectDrawEnumerate = function(lpCallback: TDDEnumCallbackA;
		911	lpContext: Pointer): HRESULT; stdcall;
		912	begin
		913	Result := TDirectDrawEnumerate(DXLoadLibrary('DDraw.dll', 'DirectDrawEnumerateA'))
		914	(lpCallback, lpContext);
		915	end;
		916
		917	var
		918	DirectDrawDrivers: TDirectXDrivers;
		919
		920	function EnumDirectDrawDrivers: TDirectXDrivers;
		921
		922	function DDENUMCALLBACK(lpGuid: PGUID; lpstrDescription: LPCSTR;
		923	lpstrModule: LPCSTR; lpContext: Pointer): BOOL; stdcall;
		924	begin
		925	Result := True;
		926	with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
		927	begin
		928	Guid := lpGuid;
		929	Description := lpstrDescription;
		930	DriverName := lpstrModule;
		931	end;
		932	end;
		933
		934	begin
		935	if DirectDrawDrivers=nil then
		936	begin
		937	DirectDrawDrivers := TDirectXDrivers.Create;
		938	try
		939	DXDirectDrawEnumerate(@DDENUMCALLBACK, DirectDrawDrivers);
		940	except
		941	DirectDrawDrivers.Free;
		942	raise;
		943	end;
		944	end;
		945
		946	Result := DirectDrawDrivers;
		947	end;
		948
		949	function ClipRect(var DestRect: TRect; const DestRect2: TRect): Boolean;
		950	begin
		951	with DestRect do
		952	begin
		953	Left := Max(Left, DestRect2.Left);
		954	Right := Min(Right, DestRect2.Right);
		955	Top := Max(Top, DestRect2.Top);
		956	Bottom := Min(Bottom, DestRect2.Bottom);
		957
		958	Result := (Left < Right) and (Top < Bottom);
		959	end;
		960	end;
		961
		962	function ClipRect2(var DestRect, SrcRect: TRect; const DestRect2, SrcRect2: TRect): Boolean;
		963	begin
		964	if DestRect.Left < DestRect2.Left then
		965	begin
		966	SrcRect.Left := SrcRect.Left + (DestRect2.Left - DestRect.Left);
		967	DestRect.Left := DestRect2.Left;
		968	end;
		969
		970	if DestRect.Top < DestRect2.Top then
		971	begin
		972	SrcRect.Top := SrcRect.Top + (DestRect2.Top - DestRect.Top);
		973	DestRect.Top := DestRect2.Top;
		974	end;
		975
		976	if SrcRect.Left < SrcRect2.Left then
		977	begin
		978	DestRect.Left := DestRect.Left + (SrcRect2.Left - SrcRect.Left);
		979	SrcRect.Left := SrcRect2.Left;
		980	end;
		981
		982	if SrcRect.Top < SrcRect2.Top then
		983	begin
		984	DestRect.Top := DestRect.Top + (SrcRect2.Top - SrcRect.Top);
		985	SrcRect.Top := SrcRect2.Top;
		986	end;
		987
		988	if DestRect.Right > DestRect2.Right then
		989	begin
		990	SrcRect.Right := SrcRect.Right - (DestRect.Right - DestRect2.Right);
		991	DestRect.Right := DestRect2.Right;
		992	end;
		993
		994	if DestRect.Bottom > DestRect2.Bottom then
		995	begin
		996	SrcRect.Bottom := SrcRect.Bottom - (DestRect.Bottom - DestRect2.Bottom);
		997	DestRect.Bottom := DestRect2.Bottom;
		998	end;
		999
		1000	if SrcRect.Right > SrcRect2.Right then
		1001	begin
		1002	DestRect.Right := DestRect.Right - (SrcRect.Right - SrcRect2.Right);
		1003	SrcRect.Right := SrcRect2.Right;
		1004	end;
		1005
		1006	if SrcRect.Bottom > SrcRect2.Bottom then
		1007	begin
		1008	DestRect.Bottom := DestRect.Bottom - (SrcRect.Bottom - SrcRect2.Bottom);
		1009	SrcRect.Bottom := SrcRect2.Bottom;
		1010	end;
		1011
		1012	Result := (DestRect.Left < DestRect.Right) and (DestRect.Top < DestRect.Bottom) and
		1013	(SrcRect.Left < SrcRect.Right) and (SrcRect.Top < SrcRect.Bottom);
		1014	end;
		1015
		1016	{ TDirectDraw }
		1017
		1018	constructor TDirectDraw.Create(GUID: PGUID);
		1019	begin
		1020	CreateEx(GUID, True);
		1021	end;
		1022
		1023	constructor TDirectDraw.CreateEx(GUID: PGUID; DirectX7Mode: Boolean);
		1024	type
		1025	TDirectDrawCreate = function(lpGUID: PGUID; out lplpDD: IDirectDraw;
		1026	pUnkOuter: IUnknown): HRESULT; stdcall;
		1027
		1028	TDirectDrawCreateEx = function(lpGUID: PGUID; out lplpDD: IDirectDraw7; const iid: TGUID;
		1029	pUnkOuter: IUnknown): HRESULT; stdcall;
		1030	begin
		1031	inherited Create;
		1032	FClippers := TList.Create;
		1033	FPalettes := TList.Create;
		1034	FSurfaces := TList.Create;
		1035
		1036	if DirectX7Mode then
		1037	begin
		1038	{ DirectX 7 }
		1039	if TDirectDrawCreateEx(DXLoadLibrary('DDraw.dll', 'DirectDrawCreateEx')) (GUID, FIDDraw7, IID_IDirectDraw7, nil)<>DD_OK then
		1040	raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
		1041	try
		1042	FIDDraw := FIDDraw7 as IDirectDraw;
		1043	FIDDraw4 := FIDDraw7 as IDirectDraw4;
		1044	except
		1045	raise EDirectDrawError.Create(SSinceDirectX7);
		1046	end;
		1047	end else
		1048	begin
		1049	if TDirectDrawCreate(DXLoadLibrary('DDraw.dll', 'DirectDrawCreate')) (GUID, FIDDraw, nil)<>DD_OK then
		1050	raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
		1051	try
		1052	FIDDraw4 := FIDDraw as IDirectDraw4;
		1053	except
		1054	raise EDirectDrawError.Create(SSinceDirectX6);
		1055	end;
		1056	end;
		1057
		1058	FDriverCaps.dwSize := SizeOf(FDriverCaps);
		1059	FHELCaps.dwSize := SizeOf(FHELCaps);
		1060	FIDDraw.GetCaps(FDriverCaps, FHELCaps);
		1061	end;
		1062
		1063	destructor TDirectDraw.Destroy;
		1064	begin
		1065	while SurfaceCount>0 do
		1066	Surfaces[SurfaceCount-1].Free;
		1067
		1068	while PaletteCount>0 do
		1069	Palettes[PaletteCount-1].Free;
		1070
		1071	while ClipperCount>0 do
		1072	Clippers[ClipperCount-1].Free;
		1073
		1074	FSurfaces.Free;
		1075	FPalettes.Free;
		1076	FClippers.Free;
		1077	inherited Destroy;
		1078	end;
		1079
		1080	class function TDirectDraw.Drivers: TDirectXDrivers;
		1081	begin
		1082	Result := EnumDirectDrawDrivers;
		1083	end;
		1084
		1085	function TDirectDraw.GetClipper(Index: Integer): TDirectDrawClipper;
		1086	begin
		1087	Result := FClippers[Index];
		1088	end;
		1089
		1090	function TDirectDraw.GetClipperCount: Integer;
		1091	begin
		1092	Result := FClippers.Count;
		1093	end;
		1094
		1095	function TDirectDraw.GetDisplayMode: TDDSurfaceDesc;
		1096	begin
		1097	Result.dwSize := SizeOf(Result);
		1098	DXResult := IDraw.GetDisplayMode(Result);
		1099	if DXResult<>DD_OK then
		1100	FillChar(Result, SizeOf(Result), 0);
		1101	end;
		1102
		1103	function TDirectDraw.GetIDDraw: IDirectDraw;
		1104	begin
		1105	if Self<>nil then
		1106	Result := FIDDraw
		1107	else
		1108	Result := nil;
		1109	end;
		1110
		1111	function TDirectDraw.GetIDDraw4: IDirectDraw4;
		1112	begin
		1113	if Self<>nil then
		1114	Result := FIDDraw4
		1115	else
		1116	Result := nil;
		1117	end;
		1118
		1119	function TDirectDraw.GetIDDraw7: IDirectDraw7;
		1120	begin
		1121	if Self<>nil then
		1122	Result := FIDDraw7
		1123	else
		1124	Result := nil;
		1125	end;
		1126
		1127	function TDirectDraw.GetIDraw: IDirectDraw;
		1128	begin
		1129	Result := IDDraw;
		1130	if Result=nil then
		1131	raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw']);
		1132	end;
		1133
		1134	function TDirectDraw.GetIDraw4: IDirectDraw4;
		1135	begin
		1136	Result := IDDraw4;
		1137	if Result=nil then
		1138	raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw4']);
		1139	end;
		1140
		1141	function TDirectDraw.GetIDraw7: IDirectDraw7;
		1142	begin
		1143	Result := IDDraw7;
		1144	if Result=nil then
		1145	raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw7']);
		1146	end;
		1147
		1148	function TDirectDraw.GetPalette(Index: Integer): TDirectDrawPalette;
		1149	begin
		1150	Result := FPalettes[Index];
		1151	end;
		1152
		1153	function TDirectDraw.GetPaletteCount: Integer;
		1154	begin
		1155	Result := FPalettes.Count;
		1156	end;
		1157
		1158	function TDirectDraw.GetSurface(Index: Integer): TDirectDrawSurface;
		1159	begin
		1160	Result := FSurfaces[Index];
		1161	end;
		1162
		1163	function TDirectDraw.GetSurfaceCount: Integer;
		1164	begin
		1165	Result := FSurfaces.Count;
		1166	end;
		1167
		1168	{ TDirectDrawPalette }
		1169
		1170	constructor TDirectDrawPalette.Create(ADirectDraw: TDirectDraw);
		1171	begin
		1172	inherited Create;
		1173	FDDraw := ADirectDraw;
		1174	FDDraw.FPalettes.Add(Self);
		1175	end;
		1176
		1177	destructor TDirectDrawPalette.Destroy;
		1178	begin
		1179	FDDraw.FPalettes.Remove(Self);
		1180	inherited Destroy;
		1181	end;
		1182
		1183	function TDirectDrawPalette.CreatePalette(Caps: DWORD; const Entries): Boolean;
		1184	var
		1185	TempPalette: IDirectDrawPalette;
		1186	begin
		1187	IDDPalette := nil;
		1188
		1189	FDDraw.DXResult := FDDraw.IDraw.CreatePalette(Caps, @Entries, TempPalette, nil);
		1190	FDXResult := FDDraw.DXResult;
		1191	Result := FDDraw.DXResult=DD_OK;
		1192	if Result then
		1193	IDDPalette := TempPalette;
		1194	end;
		1195
		1196	procedure TDirectDrawPalette.LoadFromDIB(DIB: TDIB);
		1197	var
		1198	Entries: TPaletteEntries;
		1199	begin
		1200	Entries := RGBQuadsToPaletteEntries(DIB.ColorTable);
		1201	CreatePalette(DDPCAPS_8BIT, Entries);
		1202	end;
		1203
		1204	procedure TDirectDrawPalette.LoadFromFile(const FileName: string);
		1205	var
		1206	Stream: TFileStream;
		1207	begin
		1208	Stream := TFileStream.Create(FileName, fmOpenRead);
		1209	try
		1210	LoadFromStream(Stream);
		1211	finally
		1212	Stream.Free;
		1213	end;
		1214	end;
		1215
		1216	procedure TDirectDrawPalette.LoadFromStream(Stream: TStream);
		1217	var
		1218	DIB: TDIB;
		1219	begin
		1220	DIB := TDIB.Create;
		1221	try
		1222	DIB.LoadFromStream(Stream);
		1223	if DIB.Size>0 then
		1224	LoadFromDIB(DIB);
		1225	finally
		1226	DIB.Free;
		1227	end;
		1228	end;
		1229
		1230	function TDirectDrawPalette.GetEntries(StartIndex, NumEntries: Integer;
		1231	var Entries): Boolean;
		1232	begin
		1233	if IDDPalette<>nil then
		1234	begin
		1235	DXResult := IPalette.GetEntries(0, StartIndex, NumEntries, @Entries);
		1236	Result := DXResult=DD_OK;
		1237	end else
		1238	Result := False;
		1239	end;
		1240
		1241	function TDirectDrawPalette.GetEntry(Index: Integer): TPaletteEntry;
		1242	begin
		1243	GetEntries(Index, 1, Result);
		1244	end;
		1245
		1246	function TDirectDrawPalette.GetIDDPalette: IDirectDrawPalette;
		1247	begin
		1248	if Self<>nil then
		1249	Result := FIDDPalette
		1250	else
		1251	Result := nil;
		1252	end;
		1253
		1254	function TDirectDrawPalette.GetIPalette: IDirectDrawPalette;
		1255	begin
		1256	Result := IDDPalette;
		1257	if Result=nil then
		1258	raise EDirectDrawPaletteError.CreateFmt(SNotMade, ['IDirectDrawPalette']);
		1259	end;
		1260
		1261	function TDirectDrawPalette.SetEntries(StartIndex, NumEntries: Integer;
		1262	const Entries): Boolean;
		1263	begin
		1264	if IDDPalette<>nil then
		1265	begin
		1266	DXResult := IPalette.SetEntries(0, StartIndex, NumEntries, @Entries);
		1267	Result := DXResult=DD_OK;
		1268	end else
		1269	Result := False;
		1270	end;
		1271
		1272	procedure TDirectDrawPalette.SetEntry(Index: Integer; Value: TPaletteEntry);
		1273	begin
		1274	SetEntries(Index, 1, Value);
		1275	end;
		1276
		1277	procedure TDirectDrawPalette.SetIDDPalette(Value: IDirectDrawPalette);
		1278	begin
		1279	if FIDDPalette=Value then Exit;
		1280	FIDDPalette := Value;
		1281	end;
		1282
		1283	{ TDirectDrawClipper }
		1284
		1285	constructor TDirectDrawClipper.Create(ADirectDraw: TDirectDraw);
		1286	begin
		1287	inherited Create;
		1288	FDDraw := ADirectDraw;
		1289	FDDraw.FClippers.Add(Self);
		1290
		1291	FDDraw.DXResult := FDDraw.IDraw.CreateClipper(0, FIDDClipper, nil);
		1292	if FDDraw.DXResult<>DD_OK then
		1293	raise EDirectDrawClipperError.CreateFmt(SCannotMade, [SDirectDrawClipper]);
		1294	end;
		1295
		1296	destructor TDirectDrawClipper.Destroy;
		1297	begin
		1298	FDDraw.FClippers.Remove(Self);
		1299	inherited Destroy;
		1300	end;
		1301
		1302	function TDirectDrawClipper.GetIDDClipper: IDirectDrawClipper;
		1303	begin
		1304	if Self<>nil then
		1305	Result := FIDDClipper
		1306	else
		1307	Result := nil;
		1308	end;
		1309
		1310	function TDirectDrawClipper.GetIClipper: IDirectDrawClipper;
		1311	begin
		1312	Result := IDDClipper;
		1313	if Result=nil then
		1314	raise EDirectDrawClipperError.CreateFmt(SNotMade, ['IDirectDrawClipper']);
		1315	end;
		1316
		1317	procedure TDirectDrawClipper.SetClipRects(const Rects: array of TRect);
		1318	type
		1319	PArrayRect = ^TArrayRect;
		1320	TArrayRect = array[0..0] of TRect;
		1321	var
		1322	RgnData: PRgnData;
		1323	i: Integer;
		1324	BoundsRect: TRect;
		1325	begin
		1326	BoundsRect := Rect(MaxInt, MaxInt, -MaxInt, -MaxInt);
		1327	for i:=Low(Rects) to High(Rects) do
		1328	begin
		1329	with BoundsRect do
		1330	begin
		1331	Left := Min(Rects[i].Left, Left);
		1332	Right := Max(Rects[i].Right, Right);
		1333	Top := Min(Rects[i].Top, Top);
		1334	Bottom := Max(Rects[i].Bottom, Bottom);
		1335	end;
		1336	end;
		1337
		1338	GetMem(RgnData, SizeOf(TRgnDataHeader)+SizeOf(TRect)*(High(Rects)-Low(Rects)+1));
		1339	try
		1340	with RgnData^.rdh do
		1341	begin
		1342	dwSize := SizeOf(TRgnDataHeader);
		1343	iType := RDH_RECTANGLES;
		1344	nCount := High(Rects)-Low(Rects)+1;
		1345	nRgnSize := nCount*SizeOf(TRect);
		1346	rcBound := BoundsRect;
		1347	end;
		1348	for i:=Low(Rects) to High(Rects) do
		1349	PArrayRect(@RgnData^.Buffer)^[i-Low(Rects)] := Rects[i];
		1350	DXResult := IClipper.SetClipList(RgnData, 0);
		1351	finally
		1352	FreeMem(RgnData);
		1353	end;
		1354	end;
		1355
		1356	procedure TDirectDrawClipper.SetHandle(Value: THandle);
		1357	begin
		1358	DXResult := IClipper.SetHWnd(0, Value);
		1359	end;
		1360
		1361	procedure TDirectDrawClipper.SetIDDClipper(Value: IDirectDrawClipper);
		1362	begin
		1363	if FIDDClipper=Value then Exit;
		1364	FIDDClipper := Value;
		1365	end;
		1366
		1367	{ TDirectDrawSurfaceCanvas }
		1368
		1369	constructor TDirectDrawSurfaceCanvas.Create(ASurface: TDirectDrawSurface);
		1370	begin
		1371	inherited Create;
		1372	FSurface := ASurface;
		1373	end;
		1374
		1375	destructor TDirectDrawSurfaceCanvas.Destroy;
		1376	begin
		1377	Release;
		1378	FSurface.FCanvas := nil;
		1379	inherited Destroy;
		1380	end;
		1381
		1382	procedure TDirectDrawSurfaceCanvas.CreateHandle;
		1383	begin
		1384	FSurface.DXResult := FSurface.ISurface.GetDC(FDC);
		1385	if FSurface.DXResult=DD_OK then
		1386	Handle := FDC;
		1387	end;
		1388
		1389	procedure TDirectDrawSurfaceCanvas.Release;
		1390	begin
		1391	if (FSurface.IDDSurface<>nil) and (FDC<>0) then
		1392	begin
		1393	Handle := 0;
		1394	FSurface.IDDSurface.ReleaseDC(FDC);
		1395	FDC := 0;
		1396	end;
		1397	end;
		1398
		1399	{ TDirectDrawSurface }
		1400
		1401	constructor TDirectDrawSurface.Create(ADirectDraw: TDirectDraw);
		1402	begin
		1403	inherited Create;
		1404	FDDraw := ADirectDraw;
		1405	FDDraw.FSurfaces.Add(Self);
		1406	end;
		1407
		1408	destructor TDirectDrawSurface.Destroy;
		1409	begin
		1410	FCanvas.Free;
		1411	IDDSurface := nil;
		1412	FDDraw.FSurfaces.Remove(Self);
		1413	inherited Destroy;
		1414	end;
		1415
		1416	function TDirectDrawSurface.GetIDDSurface: IDirectDrawSurface;
		1417	begin
		1418	if Self<>nil then
		1419	Result := FIDDSurface
		1420	else
		1421	Result := nil;
		1422	end;
		1423
		1424	function TDirectDrawSurface.GetIDDSurface4: IDirectDrawSurface4;
		1425	begin
		1426	if Self<>nil then
		1427	Result := FIDDSurface4
		1428	else
		1429	Result := nil;
		1430	end;
		1431
		1432	function TDirectDrawSurface.GetIDDSurface7: IDirectDrawSurface7;
		1433	begin
		1434	if Self<>nil then
		1435	Result := FIDDSurface7
		1436	else
		1437	Result := nil;
		1438	end;
		1439
		1440	function TDirectDrawSurface.GetISurface: IDirectDrawSurface;
		1441	begin
		1442	Result := IDDSurface;
		1443	if Result=nil then
		1444	raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface']);
		1445	end;
		1446
		1447	function TDirectDrawSurface.GetISurface4: IDirectDrawSurface4;
		1448	begin
		1449	Result := IDDSurface4;
		1450	if Result=nil then
		1451	raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface4']);
		1452	end;
		1453
		1454	function TDirectDrawSurface.GetISurface7: IDirectDrawSurface7;
		1455	begin
		1456	Result := IDDSurface7;
		1457	if Result=nil then
		1458	raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface7']);
		1459	end;
		1460
		1461	procedure TDirectDrawSurface.SetIDDSurface(Value: IDirectDrawSurface);
		1462	var
		1463	Clipper: IDirectDrawClipper;
		1464	begin
		1465	if Value=nil then Exit;
		1466	if Value as IDirectDrawSurface=FIDDSurface then Exit;
		1467
		1468	FIDDSurface := nil;
		1469	FIDDSurface4 := nil;
		1470	FIDDSurface7 := nil;
		1471
		1472	FStretchDrawClipper := nil;
		1473	FGammaControl := nil;
		1474	FHasClipper := False;
		1475	FLockCount := 0;
		1476	FillChar(FSurfaceDesc, SizeOf(FSurfaceDesc), 0);
		1477
		1478	if Value<>nil then
		1479	begin
		1480	FIDDSurface := Value as IDirectDrawSurface;
		1481	FIDDSurface4 := Value as IDirectDrawSurface4;
		1482	if FDDraw.FIDDraw7<>nil then FIDDSurface7 := Value as IDirectDrawSurface7;
		1483
		1484	FHasClipper := (FIDDSurface.GetClipper(Clipper)=DD_OK) and (Clipper<>nil);
		1485
		1486	FSurfaceDesc.dwSize := SizeOf(FSurfaceDesc);
		1487	FIDDSurface.GetSurfaceDesc(FSurfaceDesc);
		1488
		1489	if FDDraw.DriverCaps.dwCaps2 and DDCAPS2_PRIMARYGAMMA<>0 then
		1490	FIDDSurface.QueryInterface(IID_IDirectDrawGammaControl, FGammaControl);
		1491	end;
		1492	end;
		1493
		1494	procedure TDirectDrawSurface.SetIDDSurface4(Value: IDirectDrawSurface4);
		1495	begin
		1496	if Value=nil then
		1497	SetIDDSurface(nil)
		1498	else
		1499	SetIDDSurface(Value as IDirectDrawSurface);
		1500	end;
		1501
		1502	procedure TDirectDrawSurface.SetIDDSurface7(Value: IDirectDrawSurface7);
		1503	begin
		1504	if Value=nil then
		1505	SetIDDSurface(nil)
		1506	else
		1507	SetIDDSurface(Value as IDirectDrawSurface);
		1508	end;
		1509
		1510	procedure TDirectDrawSurface.Assign(Source: TPersistent);
		1511	var
		1512	TempSurface: IDirectDrawSurface;
		1513	begin
		1514	if Source=nil then
		1515	IDDSurface := nil
		1516	else if Source is TGraphic then
		1517	LoadFromGraphic(TGraphic(Source))
		1518	else if Source is TPicture then
		1519	LoadFromGraphic(TPicture(Source).Graphic)
		1520	else if Source is TDirectDrawSurface then
		1521	begin
		1522	if TDirectDrawSurface(Source).IDDSurface=nil then
		1523	IDDSurface := nil
		1524	else begin
		1525	FDDraw.DXResult := FDDraw.IDraw.DuplicateSurface(TDirectDrawSurface(Source).IDDSurface,
		1526	TempSurface);
		1527	if FDDraw.DXResult=0 then
		1528	begin
		1529	IDDSurface := TempSurface;
		1530	end;
		1531	end;
		1532	end else
		1533	inherited Assign(Source);
		1534	end;
		1535
		1536	procedure TDirectDrawSurface.AssignTo(Dest: TPersistent);
		1537	begin
		1538	if Dest is TDIB then
		1539	begin
		1540	TDIB(Dest).SetSize(Width, Height, 24);
		1541	TDIB(Dest).Canvas.CopyRect(Rect(0, 0, TDIB(Dest).Width, TDIB(Dest).Height), Canvas, ClientRect);
		1542	Canvas.Release;
		1543	end else
		1544	inherited AssignTo(Dest);
		1545	end;
		1546
		1547	function TDirectDrawSurface.Blt(const DestRect, SrcRect: TRect; Flags: DWORD;
		1548	const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean;
		1549	begin
		1550	if IDDSurface<>nil then
		1551	begin
		1552	DXResult := ISurface.Blt(DestRect, Source.IDDSurface, SrcRect, DWORD(Flags), DF);
		1553	Result := DXResult=DD_OK;
		1554	end else
		1555	Result := False;
		1556	end;
		1557
		1558	function TDirectDrawSurface.BltFast(X, Y: Integer; const SrcRect: TRect;
		1559	Flags: DWORD; Source: TDirectDrawSurface): Boolean;
		1560	begin
		1561	if IDDSurface<>nil then
		1562	begin
		1563	DXResult := ISurface.BltFast(X, Y, Source.IDDSurface, SrcRect, DWORD(Flags));
		1564	Result := DXResult=DD_OK;
		1565	end else
		1566	Result := False;
		1567	end;
		1568
		1569	function TDirectDrawSurface.ColorMatch(Col: TColor): Integer;
		1570	var
		1571	DIB: TDIB;
		1572	i, oldc: Integer;
		1573	begin
		1574	if IDDSurface<>nil then
		1575	begin
		1576	oldc := Pixels[0, 0];
		1577
		1578	DIB := TDIB.Create;
		1579	try
		1580	i := ColorToRGB(Col);
		1581	DIB.SetSize(1, 1, 8);
		1582	DIB.ColorTable[0] := RGBQuad(GetRValue(i), GetGValue(i), GetBValue(i));
		1583	DIB.UpdatePalette;
		1584	DIB.Pixels[0, 0] := 0;
		1585
		1586	with Canvas do
		1587	begin
		1588	Draw(0, 0, DIB);
		1589	Release;
		1590	end;
		1591	finally
		1592	DIB.Free;
		1593	end;
		1594	Result := Pixels[0, 0];
		1595	Pixels[0, 0] := oldc;
		1596	end else
		1597	Result := 0;
		1598	end;
		1599
		1600	function TDirectDrawSurface.CreateSurface(const SurfaceDesc: TDDSurfaceDesc): Boolean;
		1601	var
		1602	TempSurface: IDirectDrawSurface;
		1603	begin
		1604	IDDSurface := nil;
		1605
		1606	FDDraw.DXResult := FDDraw.IDraw.CreateSurface(SurfaceDesc, TempSurface, nil);
		1607	FDXResult := FDDraw.DXResult;
		1608	Result := FDDraw.DXResult=DD_OK;
		1609	if Result then
		1610	begin
		1611	IDDSurface := TempSurface;
		1612	TransparentColor := 0;
		1613	end;
		1614	end;
		1615
		1616	{$IFDEF DelphiX_Spt4}
		1617	function TDirectDrawSurface.CreateSurface(const SurfaceDesc: TDDSurfaceDesc2): Boolean;
		1618	var
		1619	TempSurface4: IDirectDrawSurface4;
		1620	begin
		1621	IDDSurface := nil;
		1622	FDDraw.DXResult := FDDraw.IDraw4.CreateSurface(SurfaceDesc, TempSurface4, nil);
		1623	FDXResult := FDDraw.DXResult;
		1624	Result := FDDraw.DXResult=DD_OK;
		1625	if Result then
		1626	begin
		1627	IDDSurface4 := TempSurface4;
		1628	TransparentColor := 0;
		1629	end;
		1630	end;
		1631	{$ENDIF}
		1632
		1633	procedure TDirectDrawSurface.Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
		1634	Transparent: Boolean);
		1635	const
		1636	BltFastFlags: array[Boolean] of Integer =
		1637	(DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
		1638	BltFlags: array[Boolean] of Integer =
		1639	(DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
		1640	var
		1641	DestRect: TRect;
		1642	DF: TDDBltFX;
		1643	Clipper: IDirectDrawClipper;
		1644	i: Integer;
		1645	begin
		1646	if Source<>nil then
		1647	begin
		1648	if (X>Width) or (Y>Height) then Exit;
		1649
		1650	if (SrcRect.Left>SrcRect.Right) or (SrcRect.Top>SrcRect.Bottom) then
		1651	begin
		1652	{ Mirror }
		1653	if ((X+Abs(SrcRect.Left-SrcRect.Right))<=0) or
		1654	((Y+Abs(SrcRect.Top-SrcRect.Bottom))<=0) then Exit;
		1655
		1656	DF.dwsize := SizeOf(DF);
		1657	DF.dwDDFX := 0;
		1658
		1659	if SrcRect.Left>SrcRect.Right then
		1660	begin
		1661	i := SrcRect.Left; SrcRect.Left := SrcRect.Right; SrcRect.Right := i;
		1662	DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORLEFTRIGHT;
		1663	end;
		1664
		1665	if SrcRect.Top>SrcRect.Bottom then
		1666	begin
		1667	i := SrcRect.Top; SrcRect.Top := SrcRect.Bottom; SrcRect.Bottom := i;
		1668	DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORUPDOWN;
		1669	end;
		1670
		1671	with SrcRect do
		1672	DestRect := Bounds(X, Y, Right-Left, Bottom-Top);
		1673
		1674	if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
		1675	begin
		1676	if DF.dwDDFX and DDBLTFX_MIRRORLEFTRIGHT<>0 then
		1677	begin
		1678	i := SrcRect.Left;
		1679	SrcRect.Left := Source.Width-SrcRect.Right;
		1680	SrcRect.Right := Source.Width-i;
		1681	end;
		1682
		1683	if DF.dwDDFX and DDBLTFX_MIRRORUPDOWN<>0 then
		1684	begin
		1685	i := SrcRect.Top;
		1686	SrcRect.Top := Source.Height-SrcRect.Bottom;
		1687	SrcRect.Bottom := Source.Height-i;
		1688	end;
		1689
		1690	Blt(DestRect, SrcRect, BltFlags[Transparent] or DDBLT_DDFX, df, Source);
		1691	end;
		1692	end else
		1693	begin
		1694	with SrcRect do
		1695	DestRect := Bounds(X, Y, Right-Left, Bottom-Top);
		1696
		1697	if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
		1698	begin
		1699	if FHasClipper then
		1700	begin
		1701	DF.dwsize := SizeOf(DF);
		1702	DF.dwDDFX := 0;
		1703	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1704	end else
		1705	begin
		1706	BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
		1707	if DXResult=DDERR_BLTFASTCANTCLIP then
		1708	begin
		1709	ISurface.GetClipper(Clipper);
		1710	if Clipper<>nil then FHasClipper := True;
		1711
		1712	DF.dwsize := SizeOf(DF);
		1713	DF.dwDDFX := 0;
		1714	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1715	end;
		1716	end;
		1717	end;
		1718	end;
		1719	end;
		1720	end;
		1721
		1722	{$IFDEF DelphiX_Spt4}
		1723	procedure TDirectDrawSurface.Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean);
		1724	const
		1725	BltFastFlags: array[Boolean] of Integer =
		1726	(DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
		1727	BltFlags: array[Boolean] of Integer =
		1728	(DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
		1729	var
		1730	DestRect, SrcRect: TRect;
		1731	DF: TDDBltFX;
		1732	Clipper: IDirectDrawClipper;
		1733	begin
		1734	if Source<>nil then
		1735	begin
		1736	SrcRect := Source.ClientRect;
		1737	DestRect := Bounds(X, Y, Source.Width, Source.Height);
		1738
		1739	if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
		1740	begin
		1741	if FHasClipper then
		1742	begin
		1743	DF.dwsize := SizeOf(DF);
		1744	DF.dwDDFX := 0;
		1745	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1746	end else
		1747	begin
		1748	BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
		1749	if DXResult=DDERR_BLTFASTCANTCLIP then
		1750	begin
		1751	ISurface.GetClipper(Clipper);
		1752	if Clipper<>nil then FHasClipper := True;
		1753
		1754	DF.dwsize := SizeOf(DF);
		1755	DF.dwDDFX := 0;
		1756	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1757	end;
		1758	end;
		1759	end;
		1760	end;
		1761	end;
		1762	{$ENDIF}
		1763
		1764	procedure TDirectDrawSurface.StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		1765	Transparent: Boolean);
		1766	const
		1767	BltFlags: array[Boolean] of Integer =
		1768	(DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
		1769	var
		1770	DF: TDDBltFX;
		1771	OldClipper: IDirectDrawClipper;
		1772	Clipper: TDirectDrawClipper;
		1773	begin
		1774	if Source<>nil then
		1775	begin
		1776	if (DestRect.Bottom<=DestRect.Top) or (DestRect.Right<=DestRect.Left) then Exit;
		1777	if (SrcRect.Bottom<=SrcRect.Top) or (SrcRect.Right<=SrcRect.Left) then Exit;
		1778
		1779	if FHasClipper then
		1780	begin
		1781	DF.dwsize := SizeOf(DF);
		1782	DF.dwDDFX := 0;
		1783	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1784	end else
		1785	begin
		1786	if FStretchDrawClipper=nil then
		1787	begin
		1788	Clipper := TDirectDrawClipper.Create(DDraw);
		1789	try
		1790	Clipper.SetClipRects([ClientRect]);
		1791	FStretchDrawClipper := Clipper.IClipper;
		1792	finally
		1793	Clipper.Free;
		1794	end;
		1795	end;
		1796
		1797	ISurface.GetClipper(OldClipper);
		1798	ISurface.SetClipper(FStretchDrawClipper);
		1799	DF.dwsize := SizeOf(DF);
		1800	DF.dwDDFX := 0;
		1801	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1802	ISurface.SetClipper(nil);
		1803	end;
		1804	end;
		1805	end;
		1806
		1807	{$IFDEF DelphiX_Spt4}
		1808	procedure TDirectDrawSurface.StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
		1809	Transparent: Boolean);
		1810	const
		1811	BltFlags: array[Boolean] of Integer =
		1812
		1813	(DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
		1814	var
		1815	DF: TDDBltFX;
		1816	OldClipper: IDirectDrawClipper;
		1817	Clipper: TDirectDrawClipper;
		1818	SrcRect: TRect;
		1819	begin
		1820	if Source<>nil then
		1821	begin
		1822	if (DestRect.Bottom<=DestRect.Top) or (DestRect.Right<=DestRect.Left) then Exit;
		1823	SrcRect := Source.ClientRect;
		1824
		1825	if ISurface.GetClipper(OldClipper)=DD_OK then
		1826	begin
		1827	DF.dwsize := SizeOf(DF);
		1828	DF.dwDDFX := 0;
		1829	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1830	end else
		1831	begin
		1832	if FStretchDrawClipper=nil then
		1833	begin
		1834	Clipper := TDirectDrawClipper.Create(DDraw);
		1835	try
		1836	Clipper.SetClipRects([ClientRect]);
		1837	FStretchDrawClipper := Clipper.IClipper;
		1838	finally
		1839	Clipper.Free;
		1840	end;
		1841	end;
		1842
		1843	ISurface.SetClipper(FStretchDrawClipper);
		1844	try
		1845	DF.dwsize := SizeOf(DF);
		1846	DF.dwDDFX := 0;
		1847	Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
		1848	finally
		1849	ISurface.SetClipper(nil);
		1850	end;
		1851	end;
		1852	end;
		1853	end;
		1854	{$ENDIF}
		1855
		1856	procedure TDirectDrawSurface.DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		1857	Transparent: Boolean; Alpha: Integer);
		1858	var
		1859	Src_ddsd: TDDSurfaceDesc;
		1860	DestSurface, SrcSurface: TDXR_Surface;
		1861	Blend: TDXR_Blend;
		1862	begin
		1863	if (Self.Width=0) or (Self.Height=0) then Exit;
		1864	if (Width=0) or (Height=0) then Exit;
		1865	if Source=nil then Exit;
		1866	if (Source.Width=0) or (Source.Height=0) then Exit;
		1867
		1868	if Alpha<=0 then Exit;
		1869
		1870	if dxrDDSurfaceLock(ISurface, DestSurface) then
		1871	begin
		1872	try
		1873	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		1874	begin
		1875	try
		1876	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		1877	begin
		1878	Blend := DXR_BLEND_ONE1;
		1879	end else
		1880	if Alpha>=255 then
		1881	begin
		1882	Blend := DXR_BLEND_ONE1_ADD_ONE2;
		1883	end else
		1884	begin
		1885	Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
		1886	end;
		1887
		1888	dxrCopyRectBlend(DestSurface, SrcSurface,
		1889	DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		1890	finally
		1891	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		1892	end;
		1893	end;
		1894	finally
		1895	dxrDDSurfaceUnLock(ISurface, DestSurface)
		1896	end;
		1897	end;
		1898	end;
		1899
		1900	procedure TDirectDrawSurface.DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		1901	Transparent: Boolean; Alpha: Integer);
		1902	var
		1903	Src_ddsd: TDDSurfaceDesc;
		1904	DestSurface, SrcSurface: TDXR_Surface;
		1905	Blend: TDXR_Blend;
		1906	begin
		1907	if (Self.Width=0) or (Self.Height=0) then Exit;
		1908	if (Width=0) or (Height=0) then Exit;
		1909	if Source=nil then Exit;
		1910	if (Source.Width=0) or (Source.Height=0) then Exit;
		1911
		1912	if Alpha<=0 then Exit;
		1913
		1914	if dxrDDSurfaceLock(ISurface, DestSurface) then
		1915	begin
		1916	try
		1917	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		1918	begin
		1919	try
		1920	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		1921	begin
		1922	Blend := DXR_BLEND_ONE1;
		1923	end else
		1924	if Alpha>=255 then
		1925	begin
		1926	Blend := DXR_BLEND_ONE1;
		1927	end else
		1928	begin
		1929	Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
		1930	end;
		1931
		1932	dxrCopyRectBlend(DestSurface, SrcSurface,
		1933	DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		1934	finally
		1935	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		1936	end;
		1937	end;
		1938	finally
		1939	dxrDDSurfaceUnLock(ISurface, DestSurface)
		1940	end;
		1941	end;
		1942	end;
		1943
		1944	procedure TDirectDrawSurface.DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
		1945	Transparent: Boolean; Alpha: Integer);
		1946	var
		1947	Src_ddsd: TDDSurfaceDesc;
		1948	DestSurface, SrcSurface: TDXR_Surface;
		1949	Blend: TDXR_Blend;
		1950	begin
		1951	if (Self.Width=0) or (Self.Height=0) then Exit;
		1952	if (Width=0) or (Height=0) then Exit;
		1953	if Source=nil then Exit;
		1954	if (Source.Width=0) or (Source.Height=0) then Exit;
		1955
		1956	if Alpha<=0 then Exit;
		1957
		1958	if dxrDDSurfaceLock(ISurface, DestSurface) then
		1959	begin
		1960	try
		1961	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		1962	begin
		1963	try
		1964	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		1965	begin
		1966	Blend := DXR_BLEND_ONE1;
		1967	end else
		1968	if Alpha>=255 then
		1969	begin
		1970	Blend := DXR_BLEND_ONE2_SUB_ONE1;
		1971	end else
		1972	begin
		1973	Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
		1974	end;
		1975
		1976	dxrCopyRectBlend(DestSurface, SrcSurface,
		1977	DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		1978	finally
		1979	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		1980	end;
		1981	end;
		1982	finally
		1983	dxrDDSurfaceUnLock(ISurface, DestSurface)
		1984	end;
		1985	end;
		1986	end;
		1987
		1988	procedure TDirectDrawSurface.DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
		1989	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer);
		1990	var
		1991	Src_ddsd: TDDSurfaceDesc;
		1992	DestSurface, SrcSurface: TDXR_Surface;
		1993	begin
		1994	if (Self.Width=0) or (Self.Height=0) then Exit;
		1995	if (Width=0) or (Height=0) then Exit;
		1996	if Source=nil then Exit;
		1997	if (Source.Width=0) or (Source.Height=0) then Exit;
		1998
		1999	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2000	begin
		2001	try
		2002	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2003	begin
		2004	try
		2005	dxrDrawRotateBlend(DestSurface, SrcSurface,
		2006	X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, DXR_BLEND_ONE1, 0,
		2007	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2008	finally
		2009	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2010	end;
		2011	end;
		2012	finally
		2013	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2014	end;
		2015	end;
		2016	end;
		2017
		2018	procedure TDirectDrawSurface.DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2019	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle, Alpha: Integer);
		2020	var
		2021	Src_ddsd: TDDSurfaceDesc;
		2022	DestSurface, SrcSurface: TDXR_Surface;
		2023	Blend: TDXR_Blend;
		2024	begin
		2025	if Alpha<=0 then Exit;
		2026
		2027	if (Self.Width=0) or (Self.Height=0) then Exit;
		2028	if (Width=0) or (Height=0) then Exit;
		2029	if Source=nil then Exit;
		2030	if (Source.Width=0) or (Source.Height=0) then Exit;
		2031
		2032	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2033	begin
		2034	try
		2035	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2036	begin
		2037	try
		2038	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		2039	begin
		2040	Blend := DXR_BLEND_ONE1;
		2041	end else
		2042	if Alpha>=255 then
		2043	begin
		2044	Blend := DXR_BLEND_ONE1_ADD_ONE2;
		2045	end else
		2046	begin
		2047	Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
		2048	end;
		2049
		2050	dxrDrawRotateBlend(DestSurface, SrcSurface,
		2051	X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, Blend, Alpha,
		2052	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2053	finally
		2054	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2055	end;
		2056	end;
		2057	finally
		2058	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2059	end;
		2060	end;
		2061	end;
		2062
		2063	procedure TDirectDrawSurface.DrawRotateAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2064	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle, Alpha: Integer);
		2065	var
		2066	Src_ddsd: TDDSurfaceDesc;
		2067	DestSurface, SrcSurface: TDXR_Surface;
		2068	Blend: TDXR_Blend;
		2069	begin
		2070	if Alpha<=0 then Exit;
		2071
		2072	if (Self.Width=0) or (Self.Height=0) then Exit;
		2073	if (Width=0) or (Height=0) then Exit;
		2074	if Source=nil then Exit;
		2075	if (Source.Width=0) or (Source.Height=0) then Exit;
		2076
		2077	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2078	begin
		2079	try
		2080	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2081	begin
		2082	try
		2083	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		2084	begin
		2085	Blend := DXR_BLEND_ONE1;
		2086	end else
		2087	if Alpha>=255 then
		2088	begin
		2089	Blend := DXR_BLEND_ONE1;
		2090	end else
		2091	begin
		2092	Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
		2093	end;
		2094
		2095	dxrDrawRotateBlend(DestSurface, SrcSurface,
		2096	X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, Blend, Alpha,
		2097	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2098	finally
		2099	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2100	end;
		2101	end;
		2102	finally
		2103	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2104	end;
		2105	end;
		2106	end;
		2107
		2108	procedure TDirectDrawSurface.DrawRotateSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2109	Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle, Alpha: Integer);
		2110	var
		2111	Src_ddsd: TDDSurfaceDesc;
		2112	DestSurface, SrcSurface: TDXR_Surface;
		2113	Blend: TDXR_Blend;
		2114	begin
		2115	if Alpha<=0 then Exit;
		2116
		2117	if (Self.Width=0) or (Self.Height=0) then Exit;
		2118	if (Width=0) or (Height=0) then Exit;
		2119	if Source=nil then Exit;
		2120	if (Source.Width=0) or (Source.Height=0) then Exit;
		2121
		2122	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2123	begin
		2124	try
		2125	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2126	begin
		2127	try
		2128	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		2129	begin
		2130	Blend := DXR_BLEND_ONE1;
		2131	end else
		2132	if Alpha>=255 then
		2133	begin
		2134	Blend := DXR_BLEND_ONE2_SUB_ONE1;
		2135	end else
		2136	begin
		2137	Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
		2138	end;
		2139
		2140	dxrDrawRotateBlend(DestSurface, SrcSurface,
		2141	X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, Blend, Alpha,
		2142	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2143	finally
		2144	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2145	end;
		2146	end;
		2147	finally
		2148	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2149	end;
		2150	end;
		2151	end;
		2152
		2153	procedure TDirectDrawSurface.DrawWaveX(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2154	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
		2155	var
		2156	Src_ddsd: TDDSurfaceDesc;
		2157	DestSurface, SrcSurface: TDXR_Surface;
		2158	begin
		2159	if (Self.Width=0) or (Self.Height=0) then Exit;
		2160	if (Width=0) or (Height=0) then Exit;
		2161	if Source=nil then Exit;
		2162	if (Source.Width=0) or (Source.Height=0) then Exit;
		2163
		2164	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2165	begin
		2166	try
		2167	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2168	begin
		2169	try
		2170	dxrDrawWaveXBlend(DestSurface, SrcSurface,
		2171	X, Y, Width, Height, SrcRect, amp, Len, ph, DXR_BLEND_ONE1, 0,
		2172	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2173	finally
		2174	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2175	end;
		2176	end;
		2177	finally
		2178	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2179	end;
		2180	end;
		2181	end;
		2182
		2183	procedure TDirectDrawSurface.DrawWaveXAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2184	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
		2185	var
		2186	Src_ddsd: TDDSurfaceDesc;
		2187	DestSurface, SrcSurface: TDXR_Surface;
		2188	Blend: TDXR_Blend;
		2189	begin
		2190	if Alpha<=0 then Exit;
		2191
		2192	if (Self.Width=0) or (Self.Height=0) then Exit;
		2193	if (Width=0) or (Height=0) then Exit;
		2194	if Source=nil then Exit;
		2195	if (Source.Width=0) or (Source.Height=0) then Exit;
		2196
		2197	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2198	begin
		2199	try
		2200	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2201	begin
		2202	try
		2203	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		2204	begin
		2205	Blend := DXR_BLEND_ONE1;
		2206	end else
		2207	if Alpha>=255 then
		2208	begin
		2209	Blend := DXR_BLEND_ONE1_ADD_ONE2;
		2210	end else
		2211	begin
		2212	Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
		2213	end;
		2214
		2215	dxrDrawWaveXBlend(DestSurface, SrcSurface,
		2216	X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
		2217	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2218	finally
		2219	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2220	end;
		2221	end;
		2222	finally
		2223	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2224	end;
		2225	end;
		2226	end;
		2227
		2228	procedure TDirectDrawSurface.DrawWaveXAlpha(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2229	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
		2230	var
		2231	Src_ddsd: TDDSurfaceDesc;
		2232	DestSurface, SrcSurface: TDXR_Surface;
		2233	Blend: TDXR_Blend;
		2234	begin
		2235	if Alpha<=0 then Exit;
		2236
		2237	if (Self.Width=0) or (Self.Height=0) then Exit;
		2238	if (Width=0) or (Height=0) then Exit;
		2239	if Source=nil then Exit;
		2240	if (Source.Width=0) or (Source.Height=0) then Exit;
		2241
		2242	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2243	begin
		2244	try
		2245	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2246	begin
		2247	try
		2248	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		2249	begin
		2250	Blend := DXR_BLEND_ONE1;
		2251	end else
		2252	if Alpha>=255 then
		2253	begin
		2254	Blend := DXR_BLEND_ONE1;
		2255	end else
		2256	begin
		2257	Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
		2258	end;
		2259
		2260	dxrDrawWaveXBlend(DestSurface, SrcSurface,
		2261	X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
		2262	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2263	finally
		2264	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2265	end;
		2266	end;
		2267	finally
		2268	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2269	end;
		2270	end;
		2271	end;
		2272
		2273	procedure TDirectDrawSurface.DrawWaveXSub(X, Y, Width, Height: Integer; const SrcRect: TRect;
		2274	Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
		2275	var
		2276	Src_ddsd: TDDSurfaceDesc;
		2277	DestSurface, SrcSurface: TDXR_Surface;
		2278	Blend: TDXR_Blend;
		2279	begin
		2280	if Alpha<=0 then Exit;
		2281
		2282	if (Self.Width=0) or (Self.Height=0) then Exit;
		2283	if (Width=0) or (Height=0) then Exit;
		2284	if Source=nil then Exit;
		2285	if (Source.Width=0) or (Source.Height=0) then Exit;
		2286
		2287	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2288	begin
		2289	try
		2290	if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
		2291	begin
		2292	try
		2293	if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
		2294	begin
		2295	Blend := DXR_BLEND_ONE1;
		2296	end else
		2297	if Alpha>=255 then
		2298	begin
		2299	Blend := DXR_BLEND_ONE2_SUB_ONE1;
		2300	end else
		2301	begin
		2302	Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
		2303	end;
		2304
		2305	dxrDrawWaveXBlend(DestSurface, SrcSurface,
		2306	X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
		2307	Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
		2308	finally
		2309	dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
		2310	end;
		2311	end;
		2312	finally
		2313	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2314	end;
		2315	end;
		2316	end;
		2317
		2318	procedure TDirectDrawSurface.Fill(DevColor: Longint);
		2319	var
		2320	DBltEx: TDDBltFX;
		2321	begin
		2322	DBltEx.dwSize := SizeOf(DBltEx);
		2323	DBltEx.dwFillColor := DevColor;
		2324	Blt(TRect(nil^), TRect(nil^), DDBLT_COLORFILL or DDBLT_WAIT, DBltEx, nil);
		2325	end;
		2326
		2327	procedure TDirectDrawSurface.FillRect(const Rect: TRect; DevColor: Longint);
		2328	var
		2329	DBltEx: TDDBltFX;
		2330	DestRect: TRect;
		2331	begin
		2332	DBltEx.dwSize := SizeOf(DBltEx);
		2333	DBltEx.dwFillColor := DevColor;
		2334	DestRect := Rect;
		2335	if ClipRect(DestRect, ClientRect) then
		2336	Blt(DestRect, TRect(nil^), DDBLT_COLORFILL or DDBLT_WAIT, DBltEx, nil);
		2337	end;
		2338
		2339	procedure TDirectDrawSurface.FillRectAdd(const DestRect: TRect; Color: TColor);
		2340	var
		2341	DestSurface: TDXR_Surface;
		2342	begin
		2343	if Color and $FFFFFF=0 then Exit;
		2344	if (Self.Width=0) or (Self.Height=0) then Exit;
		2345	if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
		2346	DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8)<>0 then Exit;
		2347
		2348	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2349	begin
		2350	try
		2351	dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE1_ADD_ONE2, ColorToRGB(Color));
		2352	finally
		2353	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2354	end;
		2355	end;
		2356	end;
		2357
		2358	procedure TDirectDrawSurface.FillRectAlpha(const DestRect: TRect; Color: TColor;
		2359	Alpha: Integer);
		2360	var
		2361	DestSurface: TDXR_Surface;
		2362	begin
		2363	if (Self.Width=0) or (Self.Height=0) then Exit;
		2364	if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
		2365	DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8)<>0 then Exit;
		2366
		2367	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2368	begin
		2369	try
		2370	dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2, ColorToRGB(Color) or (Byte(Alpha) shl 24));
		2371	finally
		2372	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2373	end;
		2374	end;
		2375	end;
		2376
		2377	procedure TDirectDrawSurface.FillRectSub(const DestRect: TRect; Color: TColor);
		2378	var
		2379	DestSurface: TDXR_Surface;
		2380	begin
		2381	if Color and $FFFFFF=0 then Exit;
		2382	if (Self.Width=0) or (Self.Height=0) then Exit;
		2383	if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
		2384	DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8)<>0 then Exit;
		2385
		2386	if dxrDDSurfaceLock(ISurface, DestSurface) then
		2387	begin
		2388	try
		2389	dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE2_SUB_ONE1, ColorToRGB(Color));
		2390	finally
		2391	dxrDDSurfaceUnLock(ISurface, DestSurface)
		2392	end;
		2393	end;
		2394	end;
		2395
		2396	function TDirectDrawSurface.GetBitCount: Integer;
		2397	begin
		2398	Result := SurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
		2399	end;
		2400
		2401	function TDirectDrawSurface.GetCanvas: TDirectDrawSurfaceCanvas;
		2402	begin
		2403	if FCanvas=nil then
		2404	FCanvas := TDirectDrawSurfaceCanvas.Create(Self);
		2405	Result := FCanvas;
		2406	end;
		2407
		2408	function TDirectDrawSurface.GetClientRect: TRect;
		2409	begin
		2410	Result := Rect(0, 0, Width, Height);
		2411	end;
		2412
		2413	function TDirectDrawSurface.GetHeight: Integer;
		2414	begin
		2415	Result := SurfaceDesc.dwHeight;
		2416	end;
		2417
		2418	type
		2419	PRGB = ^TRGB;
		2420	TRGB = packed record
		2421	R, G, B: Byte;
		2422	end;
		2423
		2424	function TDirectDrawSurface.GetPixel(X, Y: Integer): Longint;
		2425	var
		2426	ddsd: TDDSurfaceDesc;
		2427	begin
		2428	Result := 0;
		2429	if (IDDSurface<>nil) and (X>=0) and (X<Width) and (Y>=0) and (Y<Height) then
		2430	if Lock(PRect(nil)^, ddsd) then
		2431	begin
		2432	try
		2433	case ddsd.ddpfPixelFormat.dwRGBBitCount of
		2434	1 : Result := Integer(PByte(Integer(ddsd.lpSurface)+
		2435	Y*ddsd.lPitch+(X shr 3))^ and (1 shl (X and 7))<>0);
		2436	4 : begin
		2437	if X and 1=0 then
		2438	Result := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 1))^ shr 4
		2439	else
		2440	Result := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 1))^ and $0F;
		2441	end;
		2442	8 : Result := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X)^;
		2443	16: Result := PWord(Integer(ddsd.lpSurface)+Yddsd.lPitch+X2)^;
		2444	24: with PRGB(Integer(ddsd.lpSurface)+Yddsd.lPitch+X3)^ do
		2445	Result := R or (G shl 8) or (B shl 16);
		2446	32: Result := PInteger(Integer(ddsd.lpSurface)+Yddsd.lPitch+X4)^;
		2447	end;
		2448	finally
		2449	UnLock;
		2450	end;
		2451	end;
		2452	end;
		2453
		2454	function TDirectDrawSurface.GetWidth: Integer;
		2455	begin
		2456	Result := SurfaceDesc.dwWidth;
		2457	end;
		2458
		2459	procedure TDirectDrawSurface.LoadFromDIB(DIB: TDIB);
		2460	begin
		2461	LoadFromGraphic(DIB);
		2462	end;
		2463
		2464	procedure TDirectDrawSurface.LoadFromDIBRect(DIB: TDIB; AWidth, AHeight: Integer; const SrcRect: TRect);
		2465	begin
		2466	LoadFromGraphicRect(DIB, AWidth, AHeight, SrcRect);
		2467	end;
		2468
		2469	procedure TDirectDrawSurface.LoadFromGraphic(Graphic: TGraphic);
		2470	begin
		2471	LoadFromGraphicRect(Graphic, 0, 0, Bounds(0, 0, Graphic.Width, Graphic.Height));
		2472	end;
		2473
		2474	procedure TDirectDrawSurface.LoadFromGraphicRect(Graphic: TGraphic; AWidth, AHeight: Integer; const SrcRect: TRect);
		2475	var
		2476	Temp: TDIB;
		2477	begin
		2478	if AWidth=0 then
		2479	AWidth := SrcRect.Right-SrcRect.Left;
		2480	if AHeight=0 then
		2481	AHeight := SrcRect.Bottom-SrcRect.Top;
		2482
		2483	SetSize(AWidth, AHeight);
		2484
		2485	with SrcRect do
		2486	if Graphic is TDIB then
		2487	begin
		2488	with Canvas do
		2489	begin
		2490	StretchBlt(Handle, 0, 0, AWidth, AHeight, TDIB(Graphic).Canvas.Handle,
		2491	Left, Top, Right-Left, Bottom-Top,SRCCOPY);
		2492	Release;
		2493	end;
		2494	end else if (Right-Left=AWidth) and (Bottom-Top=AHeight) then
		2495	begin
		2496	with Canvas do
		2497	begin
		2498	Draw(-Left, -Top, Graphic);
		2499	Release;
		2500	end;
		2501	end else
		2502	begin
		2503	Temp := TDIB.Create;
		2504	try
		2505	Temp.SetSize(Right-Left, Bottom-Top, 24);
		2506	Temp.Canvas.Draw(-Left, -Top, Graphic);
		2507
		2508	with Canvas do
		2509	begin
		2510	StretchDraw(Bounds(0, 0, AWidth, AHeight), Temp);
		2511	Release;
		2512	end;
		2513	finally
		2514	Temp.Free;
		2515	end;
		2516	end;
		2517	end;
		2518
		2519	procedure TDirectDrawSurface.LoadFromFile(const FileName: string);
		2520	var
		2521	Picture: TPicture;
		2522	begin
		2523	Picture := TPicture.Create;
		2524	try
		2525	Picture.LoadFromFile(FileName);
		2526	LoadFromGraphic(Picture.Graphic);
		2527	finally
		2528	Picture.Free;
		2529	end;
		2530	end;
		2531
		2532	procedure TDirectDrawSurface.LoadFromStream(Stream: TStream);
		2533	var
		2534	DIB: TDIB;
		2535	begin
		2536	DIB := TDIB.Create;
		2537	try
		2538	DIB.LoadFromStream(Stream);
		2539	if DIB.Size>0 then
		2540	LoadFromGraphic(DIB);
		2541	finally
		2542	DIB.Free;
		2543	end;
		2544	end;
		2545
		2546	function TDirectDrawSurface.Lock(const Rect: TRect; var SurfaceDesc: TDDSurfaceDesc): Boolean;
		2547	begin
		2548	Result := False;
		2549	if IDDSurface=nil then Exit;
		2550
		2551	if FLockCount>0 then Exit;
		2552
		2553	FLockSurfaceDesc.dwSize := SizeOf(FLockSurfaceDesc);
		2554
		2555	if (@Rect<>nil) and ((Rect.Left<>0) or (Rect.Top<>0) or (Rect.Right<>Width) or (Rect.Bottom<>Height)) then
		2556	DXResult := ISurface.Lock(@Rect, FLockSurfaceDesc, DDLOCK_WAIT, 0)
		2557	else
		2558	DXResult := ISurface.Lock(nil, FLockSurfaceDesc, DDLOCK_WAIT, 0);
		2559	if DXResult<>DD_OK then Exit;
		2560
		2561	Inc(FLockCount);
		2562	SurfaceDesc := FLockSurfaceDesc;
		2563
		2564	Result := True;
		2565	end;
		2566
		2567	{$IFDEF DelphiX_Spt4}
		2568	function TDirectDrawSurface.Lock(var SurfaceDesc: TDDSurfaceDesc): Boolean;
		2569	begin
		2570	Result := False;
		2571	if IDDSurface=nil then Exit;
		2572
		2573	if FLockCount=0 then
		2574	begin
		2575	FLockSurfaceDesc.dwSize := SizeOf(FLockSurfaceDesc);
		2576	DXResult := ISurface.Lock(nil, FLockSurfaceDesc, DDLOCK_WAIT, 0);
		2577	if DXResult<>DD_OK then Exit;
		2578	end;
		2579
		2580	Inc(FLockCount);
		2581	SurfaceDesc := FLockSurfaceDesc;
		2582	Result := True;
		2583	end;
		2584	{$ENDIF}
		2585
		2586	procedure TDirectDrawSurface.UnLock;
		2587	begin
		2588	if IDDSurface=nil then Exit;
		2589
		2590	if FLockCount>0 then
		2591	begin
		2592	Dec(FLockCount);
		2593	if FLockCount=0 then
		2594	DXResult := ISurface.UnLock(FLockSurfaceDesc.lpSurface);
		2595	end;
		2596	end;
		2597
		2598	function TDirectDrawSurface.Restore: Boolean;
		2599	begin
		2600	if IDDSurface<>nil then
		2601	begin
		2602	DXResult := ISurface.Restore;
		2603	Result := DXResult=DD_OK;
		2604	end else
		2605	Result := False;
		2606	end;
		2607
		2608	procedure TDirectDrawSurface.SetClipper(Value: TDirectDrawClipper);
		2609	begin
		2610	if IDDSurface<>nil then
		2611	DXResult := ISurface.SetClipper(Value.IDDClipper);
		2612	FHasClipper := (Value<>nil) and (DXResult=DD_OK);
		2613	end;
		2614
		2615	procedure TDirectDrawSurface.SetColorKey(Flags: DWORD; const Value: TDDColorKey);
		2616	begin
		2617	if IDDSurface<>nil then
		2618	DXResult := ISurface.SetColorKey(Flags, Value);
		2619	end;
		2620
		2621	procedure TDirectDrawSurface.SetPalette(Value: TDirectDrawPalette);
		2622	begin
		2623	if IDDSurface<>nil then
		2624	DXResult := ISurface.SetPalette(Value.IDDPalette);
		2625	end;
		2626
		2627	procedure TDirectDrawSurface.SetPixel(X, Y: Integer; Value: Longint);
		2628	var
		2629	ddsd: TDDSurfaceDesc;
		2630	P: PByte;
		2631	begin
		2632	if (IDDSurface<>nil) and (X>=0) and (X<Width) and (Y>=0) and (Y<Height) then
		2633	if Lock(PRect(nil)^, ddsd) then
		2634	begin
		2635	try
		2636	case ddsd.ddpfPixelFormat.dwRGBBitCount of
		2637	1 : begin
		2638	P := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 3));
		2639	if Value=0 then
		2640	P^ := P^ and (not (1 shl (7-(X and 7))))
		2641	else
		2642	P^ := P^ or (1 shl (7-(X and 7)));
		2643	end;
		2644	4 : begin
		2645	P := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 1));
		2646	if X and 1=0 then
		2647	P^ := (P^ and $0F) or (Value shl 4)
		2648	else
		2649	P^ := (P^ and $F0) or (Value and $0F);
		2650	end;
		2651	8 : PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X)^ := Value;
		2652	16: PWord(Integer(ddsd.lpSurface)+Yddsd.lPitch+X2)^ := Value;
		2653	24: with PRGB(Integer(ddsd.lpSurface)+Yddsd.lPitch+X3)^ do
		2654	begin
		2655	R := Byte(Value);
		2656	G := Byte(Value shr 8);
		2657	B := Byte(Value shr 16);
		2658	end;
		2659	32: PInteger(Integer(ddsd.lpSurface)+Yddsd.lPitch+X4)^ := Value;
		2660	end;
		2661	finally
		2662	UnLock;
		2663	end;
		2664	end;
		2665	end;
		2666
		2667	procedure TDirectDrawSurface.SetSize(AWidth, AHeight: Integer);
		2668	var
		2669	ddsd: TDDSurfaceDesc;
		2670	begin
		2671	if (AWidth<=0) or (AHeight<=0) then
		2672	begin
		2673	IDDSurface := nil;
		2674	Exit;
		2675	end;
		2676
		2677	with ddsd do
		2678	begin
		2679	dwSize := SizeOf(ddsd);
		2680	dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
		2681	ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
		2682	if FSystemMemory then
		2683	ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
		2684	dwHeight := AHeight;
		2685	dwWidth := AWidth;
		2686	end;
		2687
		2688	if CreateSurface(ddsd) then Exit;
		2689
		2690	{ When the Surface cannot be made, making is attempted to the system memory. }
		2691	if ddsd.ddsCaps.dwCaps and DDSCAPS_SYSTEMMEMORY=0 then
		2692	begin
		2693	ddsd.ddsCaps.dwCaps := (ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY)) or DDSCAPS_SYSTEMMEMORY;
		2694	if CreateSurface(ddsd) then
		2695	begin
		2696	FSystemMemory := True;
		2697	Exit;
		2698	end;
		2699	end;
		2700
		2701	raise EDirectDrawSurfaceError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
		2702	end;
		2703
		2704	procedure TDirectDrawSurface.SetTransparentColor(Col: Longint);
		2705	var
		2706	ddck: TDDColorKey;
		2707	begin
		2708	ddck.dwColorSpaceLowValue := Col;
		2709	ddck.dwColorSpaceHighValue := Col;
		2710	ColorKey[DDCKEY_SRCBLT] := ddck;
		2711	end;
		2712
		2713	{ TDXDrawDisplayMode }
		2714
		2715	function TDXDrawDisplayMode.GetBitCount: Integer;
		2716	begin
		2717	Result := FSurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
		2718	end;
		2719
		2720	function TDXDrawDisplayMode.GetHeight: Integer;
		2721	begin
		2722	Result := FSurfaceDesc.dwHeight;
		2723	end;
		2724
		2725	function TDXDrawDisplayMode.GetWidth: Integer;
		2726	begin
		2727	Result := FSurfaceDesc.dwWidth;
		2728	end;
		2729
		2730	{ TDXDrawDisplay }
		2731
		2732	constructor TDXDrawDisplay.Create(ADXDraw: TCustomDXDraw);
		2733	begin
		2734	inherited Create;
		2735	FDXDraw := ADXDraw;
		2736	FModes := TCollection.Create(TDXDrawDisplayMode);
		2737	FWidth := 640;
		2738	FHeight := 480;
		2739	FBitCount := 8;
		2740	FFixedBitCount := True;
		2741	FFixedRatio := True;
		2742	FFixedSize := False;
		2743	end;
		2744
		2745	destructor TDXDrawDisplay.Destroy;
		2746	begin
		2747	FModes.Free;
		2748	inherited Destroy;
		2749	end;
		2750
		2751	procedure TDXDrawDisplay.Assign(Source: TPersistent);
		2752	begin
		2753	if Source is TDXDrawDisplay then
		2754	begin
		2755	if Source<>Self then
		2756	begin
		2757	FBitCount := TDXDrawDisplay(Source).BitCount;
		2758	FHeight := TDXDrawDisplay(Source).Height;
		2759	FWidth := TDXDrawDisplay(Source).Width;
		2760
		2761	FFixedBitCount := TDXDrawDisplay(Source).FFixedBitCount;
		2762	FFixedRatio := TDXDrawDisplay(Source).FFixedRatio;
		2763	FFixedSize := TDXDrawDisplay(Source).FFixedSize;
		2764	end;
		2765	end else
		2766	inherited Assign(Source);
		2767	end;
		2768
		2769	function TDXDrawDisplay.GetCount: Integer;
		2770	begin
		2771	if FModes.Count=0 then
		2772	LoadDisplayModes;
		2773	Result := FModes.Count;
		2774	end;
		2775
		2776	function TDXDrawDisplay.GetMode: TDXDrawDisplayMode;
		2777	var
		2778	i: Integer;
		2779	ddsd: TDDSurfaceDesc;
		2780	begin
		2781	Result := nil;
		2782	if FDXDraw.DDraw<>nil then
		2783	begin
		2784	ddsd := FDXDraw.DDraw.DisplayMode;
		2785	with ddsd do
		2786	i := IndexOf(dwWidth, dwHeight, ddpfPixelFormat.dwRGBBitCount);
		2787	if i<>-1 then
		2788	Result := Modes[i];
		2789	end;
		2790	if Result=nil then
		2791	raise EDirectDrawError.Create(SDisplayModeCannotAcquired);
		2792	end;
		2793
		2794	function TDXDrawDisplay.GetMode2(Index: Integer): TDXDrawDisplayMode;
		2795	begin
		2796	if FModes.Count=0 then
		2797	LoadDisplayModes;
		2798	Result := TDXDrawDisplayMode(FModes.Items[Index]);
		2799	end;
		2800
		2801	function TDXDrawDisplay.IndexOf(Width, Height, BitCount: Integer): Integer;
		2802	var
		2803	i: Integer;
		2804	begin
		2805	Result := -1;
		2806	for i:=0 to Count-1 do
		2807	if (Modes[i].Width=Width) and (Modes[i].Height=Height) and (Modes[i].BitCount=BitCount) then
		2808	begin
		2809	Result := i;
		2810	Exit;
		2811	end;
		2812	end;
		2813
		2814	procedure TDXDrawDisplay.LoadDisplayModes;
		2815
		2816	function EnumDisplayModesProc(const lpTDDSurfaceDesc: TDDSurfaceDesc;
		2817	lpContext: Pointer): HRESULT; stdcall;
		2818	begin
		2819	with TDXDrawDisplayMode.Create(TCollection(lpContext)) do
		2820	FSurfaceDesc := lpTDDSurfaceDesc;
		2821	Result := DDENUMRET_OK;
		2822	end;
		2823
		2824	function Compare(Item1, Item2: TDXDrawDisplayMode): Integer;
		2825	begin
		2826	if Item1.Width<>Item2.Width then
		2827	Result := Item1.Width-Item2.Width
		2828	else if Item1.Height<>Item2.Height then
		2829	Result := Item1.Height-Item2.Height
		2830	else
		2831	Result := Item1.BitCount-Item2.BitCount;
		2832	end;
		2833
		2834	var
		2835	DDraw: TDirectDraw;
		2836	TempList: TList;
		2837	i: Integer;
		2838	begin
		2839	FModes.Clear;
		2840
		2841	if FDXDraw.DDraw<>nil then
		2842	begin
		2843	FDXDraw.DDraw.DXResult := FDXDraw.DDraw.IDraw.EnumDisplayModes(0, PDDSurfaceDesc(nil)^,
		2844	FModes, @EnumDisplayModesProc);
		2845	end else
		2846	begin
		2847	DDraw := TDirectDraw.Create(PGUID(FDXDraw.FDriver));
		2848	try
		2849	DDraw.IDraw.EnumDisplayModes(0, PDDSurfaceDesc(nil)^, FModes, @EnumDisplayModesProc);
		2850	finally
		2851	DDraw.Free;
		2852	end;
		2853	end;
		2854
		2855	TempList := TList.Create;
		2856	try
		2857	for i:=0 to FModes.Count-1 do
		2858	TempList.Add(FModes.Items[i]);
		2859	TempList.Sort(@Compare);
		2860
		2861	for i:=FModes.Count-1 downto 0 do
		2862	TDXDrawDisplayMode(TempList[i]).Index := i;
		2863	finally
		2864	TempList.Free;
		2865	end;
		2866	end;
		2867
		2868	function TDXDrawDisplay.SetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
		2869	begin
		2870	Result := False;
		2871	if FDXDraw.DDraw<>nil then
		2872	begin
		2873	FDXDraw.DDraw.DXResult := FDXDraw.DDraw.IDraw.SetDisplayMode(AWidth, AHeight, ABitCount);
		2874	Result := FDXDraw.DDraw.DXResult=DD_OK;
		2875
		2876	if Result then
		2877	begin
		2878	FWidth := AWidth;
		2879	FHeight := AHeight;
		2880	FBitCount := ABitCount;
		2881	end;
		2882	end;
		2883	end;
		2884
		2885	function TDXDrawDisplay.DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
		2886
		2887	function TestBitCount(BitCount, ABitCount: Integer): Boolean;
		2888	begin
		2889	if (BitCount>8) and (ABitCount>8) then
		2890	begin
		2891	Result := True;
		2892	end else
		2893	begin
		2894	Result := BitCount>=ABitCount;
		2895	end;
		2896	end;
		2897
		2898	function SetSize2(Ratio: Boolean): Boolean;
		2899	var
		2900	DWidth, DHeight, DBitCount, i: Integer;
		2901	Flag: Boolean;
		2902	begin
		2903	Result := False;
		2904
		2905	DWidth := Maxint;
		2906	DHeight := Maxint;
		2907	DBitCount := ABitCount;
		2908
		2909	Flag := False;
		2910	for i:=0 to Count-1 do
		2911	with Modes[i] do
		2912	begin
		2913	if ((DWidth>=Width) and (DHeight>=Width) and
		2914	((not Ratio) or (Width/Height=AWidth/AHeight)) and
		2915	((FFixedSize and (Width=AWidth) and (Height=Height)) or
		2916	((not FFixedSize) and (Width>=AWidth) and (Height>=AHeight))) and
		2917
		2918	((FFixedBitCount and (BitCount=ABitCount)) or
		2919	((not FFixedBitCount) and TestBitCount(BitCount, ABitCount)))) then
		2920	begin
		2921	DWidth := Width;
		2922	DHeight := Height;
		2923	DBitCount := BitCount;
		2924	Flag := True;
		2925	end;
		2926	end;
		2927
		2928	if Flag then
		2929	begin
		2930	if (DBitCount<>ABitCount) then
		2931	begin
		2932	if IndexOf(DWidth, DHEight, ABitCount)<>-1 then
		2933	DBitCount := ABitCount;
		2934	end;
		2935
		2936	Result := SetSize(DWidth, DHeight, DBitCount);
		2937	end;
		2938	end;
		2939
		2940	begin
		2941	Result := False;
		2942
		2943	if (AWidth<=0) or (AHeight<=0) or (not (ABitCount in [8, 16, 24, 32])) then Exit;
		2944
		2945	{ The change is attempted by the size of default. }
		2946	if SetSize(AWidth, AHeight, ABitCount) then
		2947	begin
		2948	Result := True;
		2949	Exit;
		2950	end;
		2951
		2952	{ The change is attempted by the screen ratio fixation. }
		2953	if FFixedRatio then
		2954	if SetSize2(True) then
		2955	begin
		2956	Result := True;
		2957	Exit;
		2958	end;
		2959
		2960	{ The change is unconditionally attempted. }
		2961	if SetSize2(False) then
		2962	begin
		2963	Result := True;
		2964	Exit;
		2965	end;
		2966	end;
		2967
		2968	procedure TDXDrawDisplay.SetBitCount(Value: Integer);
		2969	begin
		2970	if not (Value in [8, 16, 24, 32]) then
		2971	raise EDirectDrawError.Create(SInvalidDisplayBitCount);
		2972	FBitCount := Value;
		2973	end;
		2974
		2975	procedure TDXDrawDisplay.SetHeight(Value: Integer);
		2976	begin
		2977	FHeight := Max(Value, 0);
		2978	end;
		2979
		2980	procedure TDXDrawDisplay.SetWidth(Value: Integer);
		2981	begin
		2982	FWidth := Max(Value, 0);
		2983	end;
		2984
		2985	{ TCustomDXDraw }
		2986
		2987	function BPPToDDBD(BPP: DWORD): DWORD;
		2988	begin
		2989	case BPP of
		2990	1: Result := DDBD_1;
		2991	2: Result := DDBD_2;
		2992	4: Result := DDBD_4;
		2993	8: Result := DDBD_8;
		2994	16: Result := DDBD_16;
		2995	24: Result := DDBD_24;
		2996	32: Result := DDBD_32;
		2997	else
		2998	Result := 0;
		2999	end;
		3000	end;
		3001
		3002	procedure FreeZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface);
		3003	begin
		3004	if ZBuffer<>nil then
		3005	begin
		3006	if (Surface.IDDSurface<>nil) and (ZBuffer.IDDSurface<>nil) then
		3007	Surface.ISurface.DeleteAttachedSurface(0, ZBuffer.IDDSurface);
		3008	ZBuffer.Free; ZBuffer := nil;
		3009	end;
		3010	end;
		3011
		3012	type
		3013	TInitializeDirect3DOption = (idoSelectDriver, idoOptimizeDisplayMode,
		3014	idoHardware, idoRetainedMode, idoZBuffer);
		3015
		3016	TInitializeDirect3DOptions = set of TInitializeDirect3DOption;
		3017
		3018	procedure Direct3DInitializing(Options: TInitializeDirect3DOptions;
		3019	var BitCount: Integer; var Driver: PGUID; var DriverGUID: TGUID);
		3020	type
		3021	PDirect3DInitializingRecord = ^TDirect3DInitializingRecord;
		3022	TDirect3DInitializingRecord = record
		3023	Options: TInitializeDirect3DOptions;
		3024	Driver: ^PGUID;
		3025	DriverGUID: PGUID;
		3026	BitCount: Integer;
		3027
		3028	Flag: Boolean;
		3029	DriverCaps: TDDCaps;
		3030	HELCaps: TDDCaps;
		3031	HWDeviceDesc: TD3DDeviceDesc;
		3032	HELDeviceDesc: TD3DDeviceDesc;
		3033	DeviceDesc: TD3DDeviceDesc;
		3034
		3035	D3DFlag: Boolean;
		3036	HWDeviceDesc2: TD3DDeviceDesc;
		3037	HELDeviceDesc2: TD3DDeviceDesc;
		3038	DeviceDesc2: TD3DDeviceDesc;
		3039	end;
		3040
		3041	function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
		3042	const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: TD3DDeviceDesc;
		3043	rec: PDirect3DInitializingRecord): HRESULT; stdcall;
		3044
		3045	procedure UseThisDevice;
		3046	begin
		3047	rec.D3DFlag := True;
		3048	rec.HWDeviceDesc2 := lpD3DHWDeviceDesc;
		3049	rec.HELDeviceDesc2 := lpD3DHELDeviceDesc;
		3050	rec.DeviceDesc2 := lpD3DHWDeviceDesc;
		3051	end;
		3052
		3053	begin
		3054	Result := D3DENUMRET_OK;
		3055
		3056	if lpD3DHWDeviceDesc.dcmColorModel=0 then Exit;
		3057
		3058	if idoOptimizeDisplayMode in rec.Options then
		3059	begin
		3060	if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32))=0 then Exit;
		3061	end else
		3062	begin
		3063	if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then Exit;
		3064	end;
		3065
		3066	UseThisDevice;
		3067	end;
		3068
		3069	function EnumDirectDrawDriverCallback(lpGUID: PGUID; lpDriverDescription: LPSTR;
		3070	lpDriverName: LPSTR; rec: PDirect3DInitializingRecord): HRESULT; stdcall;
		3071	var
		3072	DDraw: TDirectDraw;
		3073	Direct3D: IDirect3D;
		3074	Direct3D7: IDirect3D7;
		3075
		3076	function CountBitMask(i: DWORD; const Bits: array of DWORD): DWORD;
		3077	var
		3078	j: Integer;
		3079	begin
		3080	Result := 0;
		3081
		3082	for j:=Low(Bits) to High(Bits) do
		3083	begin
		3084	if i and Bits[j]<>0 then
		3085	Inc(Result);
		3086	end;
		3087	end;
		3088
		3089	function CompareCountBitMask(i, i2: DWORD; const Bits: array of DWORD): Integer;
		3090	var
		3091	j, j2: DWORD;
		3092	begin
		3093	j := CountBitMask(i, Bits);
		3094	j2 := CountBitMask(i2, Bits);
		3095
		3096	if j<j2 then
		3097	Result := -1
		3098	else if i>j2 then
		3099	Result := 1
		3100	else
		3101	Result := 0;
		3102	end;
		3103
		3104	function CountBit(i: DWORD): DWORD;
		3105	var
		3106	j: Integer;
		3107	begin
		3108	Result := 0;
		3109
		3110	for j:=0 to 31 do
		3111	if i and (1 shl j)<>0 then
		3112	Inc(Result);
		3113	end;
		3114
		3115	function CompareCountBit(i, i2: DWORD): Integer;
		3116	begin
		3117	Result := CountBit(i)-CountBit(i2);
		3118	if Result<0 then Result := -1;
		3119	if Result>0 then Result := 1;
		3120	end;
		3121
		3122	function FindDevice: Boolean;
		3123	begin
		3124	{ The Direct3D driver is examined. }
		3125	rec.D3DFlag := False;
		3126	Direct3D.EnumDevices(@EnumDeviceCallBack, rec);
		3127	Result := rec.D3DFlag;
		3128
		3129	if not Result then Exit;
		3130
		3131	{ Comparison of DirectDraw driver. }
		3132	if not rec.Flag then
		3133	begin
		3134	rec.HWDeviceDesc := rec.HWDeviceDesc2;
		3135	rec.HELDeviceDesc := rec.HELDeviceDesc2;
		3136	rec.DeviceDesc := rec.DeviceDesc2;
		3137	rec.Flag := True;
		3138	end else
		3139	begin
		3140	{ Comparison of hardware. (One with large number of functions to support is chosen. }
		3141	Result := False;
		3142
		3143	if DDraw.DriverCaps.dwVidMemTotal<rec.DriverCaps.dwVidMemTotal then Exit;
		3144
		3145	if CompareCountBitMask(DDraw.DriverCaps.ddscaps.dwCaps, rec.DriverCaps.ddscaps.dwCaps, [DDSCAPS_TEXTURE, DDSCAPS_ZBUFFER, DDSCAPS_MIPMAP])+
		3146	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwMiscCaps, rec.HWDeviceDesc2.dpcLineCaps.dwMiscCaps)+
		3147	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwRasterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwRasterCaps)+
		3148	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwAlphaCmpCaps, rec.HWDeviceDesc2.dpcLineCaps.dwAlphaCmpCaps)+
		3149	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwSrcBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwSrcBlendCaps)+
		3150	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwDestBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwDestBlendCaps)+
		3151	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwShadeCaps, rec.HWDeviceDesc2.dpcLineCaps.dwShadeCaps)+
		3152	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureCaps)+
		3153	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureFilterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureFilterCaps)+
		3154	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureBlendCaps)+
		3155	CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureAddressCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureAddressCaps)<0 then Exit;
		3156
		3157	Result := True;
		3158	end;
		3159	end;
		3160
		3161	begin
		3162	Result := DDENUMRET_OK;
		3163
		3164	DDraw := TDirectDraw.Create(lpGUID);
		3165	try
		3166	if (DDraw.DriverCaps.dwCaps and DDCAPS_3D<>0) and
		3167	(DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE<>0) then
		3168	begin
		3169	if DDraw.IDDraw7<>nil then
		3170	Direct3D7 := DDraw.IDraw7 as IDirect3D7
		3171	else
		3172	Direct3D := DDraw.IDraw as IDirect3D;
		3173	try
		3174	if FindDevice then
		3175	begin
		3176	rec.DriverCaps := DDraw.DriverCaps;
		3177	rec.HELCaps := DDraw.HELCaps;
		3178
		3179	if lpGUID=nil then
		3180	rec.Driver := nil
		3181	else begin
		3182	rec.DriverGUID^ := lpGUID^;
		3183	rec.Driver^ := @rec.DriverGUID;
		3184	end;
		3185	end;
		3186	finally
		3187	Direct3D := nil;
		3188	Direct3D7 := nil;
		3189	end;
		3190	end;
		3191	finally
		3192	DDraw.Free;
		3193	end;
		3194	end;
		3195
		3196	var
		3197	rec: TDirect3DInitializingRecord;
		3198	DDraw: TDirectDraw;
		3199	begin
		3200	FillChar(rec, SizeOf(rec), 0);
		3201	rec.BitCount := BitCount;
		3202	rec.Options := Options;
		3203
		3204	{ Driver selection }
		3205	if idoSelectDriver in Options then
		3206	begin
		3207	rec.Flag := False;
		3208	rec.Options := Options;
		3209	rec.Driver := @Driver;
		3210	rec.DriverGUID := @DriverGUID;
		3211	DXDirectDrawEnumerate(@EnumDirectDrawDriverCallback, @rec)
		3212	end else
		3213	begin
		3214	DDraw := TDirectDraw.Create(Driver);
		3215	try
		3216	rec.DriverCaps := DDraw.DriverCaps;
		3217	rec.HELCaps := DDraw.HELCaps;
		3218
		3219	rec.D3DFlag := False;
		3220	(DDraw.IDraw as IDirect3D).EnumDevices(@EnumDeviceCallBack, @rec);
		3221
		3222	if rec.D3DFlag then
		3223	rec.DeviceDesc := rec.DeviceDesc2;
		3224	finally
		3225	DDraw.Free;
		3226	end;
		3227	rec.Flag := True;
		3228	end;
		3229
		3230	{ Display mode optimization }
		3231	if rec.Flag and (idoOptimizeDisplayMode in Options) then
		3232	begin
		3233	if (rec.DeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then
		3234	begin
		3235	if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_16<>0 then
		3236	rec.BitCount := 16
		3237	else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_24<>0 then
		3238	rec.BitCount := 24
		3239	else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_32<>0 then
		3240	rec.BitCount := 32;
		3241	end;
		3242	end;
		3243
		3244	BitCount := rec.BitCount;
		3245	end;
		3246
		3247	procedure Direct3DInitializing_DXDraw(Options: TInitializeDirect3DOptions;
		3248	DXDraw: TCustomDXDraw);
		3249	var
		3250	BitCount: Integer;
		3251	Driver: PGUID;
		3252	DriverGUID: TGUID;
		3253	begin
		3254	BitCount := DXDraw.Display.BitCount;
		3255	Driver := DXDraw.Driver;
		3256	Direct3DInitializing(Options, BitCount, Driver, DriverGUID);
		3257	DXDraw.Driver := Driver;
		3258	DXDraw.Display.BitCount := BitCount;
		3259	end;
		3260
		3261	procedure InitializeDirect3D(Surface: TDirectDrawSurface;
		3262	var ZBuffer: TDirectDrawSurface;
		3263	out D3D: IDirect3D;
		3264	out D3D2: IDirect3D2;
		3265	out D3D3: IDirect3D3;
		3266	out D3DDevice: IDirect3DDevice;
		3267	out D3DDevice2: IDirect3DDevice2;
		3268	out D3DDevice3: IDirect3DDevice3;
		3269	var D3DRM: IDirect3DRM;
		3270	var D3DRM2: IDirect3DRM2;
		3271	var D3DRM3: IDirect3DRM3;
		3272	out D3DRMDevice: IDirect3DRMDevice;
		3273	out D3DRMDevice2: IDirect3DRMDevice2;
		3274	out D3DRMDevice3: IDirect3DRMDevice3;
		3275	out Viewport: IDirect3DRMViewport;
		3276	var Scene: IDirect3DRMFrame;
		3277	var Camera: IDirect3DRMFrame;
		3278	var NowOptions: TInitializeDirect3DOptions);
		3279	type
		3280	TInitializeDirect3DRecord = record
		3281	Flag: Boolean;
		3282	BitCount: Integer;
		3283	HWDeviceDesc: TD3DDeviceDesc;
		3284	HELDeviceDesc: TD3DDeviceDesc;
		3285	DeviceDesc: TD3DDeviceDesc;
		3286	Hardware: Boolean;
		3287	Options: TInitializeDirect3DOptions;
		3288	GUID: TGUID;
		3289	SupportHardware: Boolean;
		3290	end;
		3291
		3292	function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
		3293	const DeviceDesc: TD3DDeviceDesc; Hardware: Boolean): Boolean;
		3294	const
		3295	MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
		3296	var
		3297	ZBufferBitDepth: Integer;
		3298	ddsd: TDDSurfaceDesc;
		3299	begin
		3300	Result := False;
		3301	FreeZBufferSurface(Surface, ZBuffer);
		3302
		3303	if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16<>0 then
		3304	ZBufferBitDepth := 16
		3305	else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24<>0 then
		3306	ZBufferBitDepth := 24
		3307	else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32<>0 then
		3308	ZBufferBitDepth := 32
		3309	else
		3310	ZBufferBitDepth := 0;
		3311
		3312	if ZBufferBitDepth<>0 then
		3313	begin
		3314	with ddsd do
		3315	begin
		3316	dwSize := SizeOf(ddsd);
		3317	Surface.ISurface.GetSurfaceDesc(ddsd);
		3318	dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
		3319	ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
		3320	dwHeight := Surface.Height;
		3321	dwWidth := Surface.Width;
		3322	dwZBufferBitDepth := ZBufferBitDepth;
		3323	end;
		3324
		3325	ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
		3326	if ZBuffer.CreateSurface(ddsd) then
		3327	begin
		3328	if Surface.ISurface.AddAttachedSurface(ZBuffer.ISurface)<>DD_OK then
		3329	begin
		3330	ZBuffer.Free; ZBuffer := nil;
		3331	Exit;
		3332	end;
		3333	Result := True;
		3334	end else
		3335	begin
		3336	ZBuffer.Free; ZBuffer := nil;
		3337	Exit;
		3338	end;
		3339	end;
		3340	end;
		3341
		3342
		3343	function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
		3344	const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: TD3DDeviceDesc;
		3345	lpUserArg: Pointer): HRESULT; stdcall;
		3346	var
		3347	dev: ^TD3DDeviceDesc;
		3348	Hardware: Boolean;
		3349	rec: ^TInitializeDirect3DRecord;
		3350
		3351	procedure UseThisDevice;
		3352	begin
		3353	rec.Flag := True;
		3354	rec.GUID := lpGUID;
		3355	rec.HWDeviceDesc := lpD3DHWDeviceDesc;
		3356	rec.HELDeviceDesc := lpD3DHELDeviceDesc;
		3357	rec.DeviceDesc := dev^;
		3358	rec.Hardware := Hardware;
		3359	end;
		3360
		3361	begin
		3362	Result := D3DENUMRET_OK;
		3363	rec := lpUserArg;
		3364
		3365	Hardware := lpD3DHWDeviceDesc.dcmColorModel<>0;
		3366	if Hardware then
		3367	dev := @lpD3DHWDeviceDesc
		3368	else
		3369	dev := @lpD3DHELDeviceDesc;
		3370
		3371	if (Hardware) and (not rec.SupportHardware) then Exit;
		3372	if dev.dcmColorModel<>D3DCOLOR_RGB then Exit;
		3373	if CompareMem(@lpGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
		3374
		3375	{ Bit depth test. }
		3376	if (dev.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then Exit;
		3377
		3378	if Hardware then
		3379	begin
		3380	{ Hardware }
		3381	UseThisDevice;
		3382	end else
		3383	begin
		3384	{ Software }
		3385	if not rec.Hardware then
		3386	UseThisDevice;
		3387	end;
		3388	end;
		3389
		3390	var
		3391	Hardware: Boolean;
		3392	SupportHardware: Boolean;
		3393	D3DDeviceGUID: TGUID;
		3394	Options: TInitializeDirect3DOptions;
		3395
		3396	procedure InitDevice;
		3397	var
		3398	rec: TInitializeDirect3DRecord;
		3399	begin
		3400	{ Device search }
		3401	rec.Flag := False;
		3402	rec.BitCount := Surface.BitCount;
		3403	rec.Hardware := False;
		3404	rec.Options := Options;
		3405	rec.SupportHardware := SupportHardware;
		3406
		3407	D3D3.EnumDevices(@EnumDeviceCallBack, @rec);
		3408	if not rec.Flag then
		3409	raise EDXDrawError.Create(S3DDeviceNotFound);
		3410
		3411	Hardware := rec.Hardware;
		3412	D3DDeviceGUID := rec.GUID;
		3413
		3414	if Hardware then
		3415	NowOptions := NowOptions + [idoHardware];
		3416
		3417	{ Z buffer making }
		3418	NowOptions := NowOptions - [idoZBuffer];
		3419	if idoZBuffer in Options then
		3420	begin
		3421	if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
		3422	NowOptions := NowOptions + [idoZBuffer];
		3423	end;
		3424	end;
		3425
		3426	type
		3427	TDirect3DRMCreate= function(out lplpDirect3DRM: IDirect3DRM): HRESULT; stdcall;
		3428	begin
		3429	try
		3430	Options := NowOptions;
		3431	NowOptions := [];
		3432
		3433	D3D3 := Surface.DDraw.IDraw as IDirect3D3;
		3434	D3D2 := D3D3 as IDirect3D2;
		3435	D3D := D3D3 as IDirect3D;
		3436
		3437	{ Whether hardware can be used is tested. }
		3438	SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY<>0) and
		3439	(idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D<>0);
		3440
		3441	if Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE=0 then
		3442	SupportHardware := False;
		3443
		3444	{ Direct3D }
		3445	InitDevice;
		3446
		3447	if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil)<>D3D_OK then
		3448	begin
		3449	SupportHardware := False;
		3450	InitDevice;
		3451	if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil)<>D3D_OK then
		3452	raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice3']);
		3453	end;
		3454
		3455	if SupportHardware then NowOptions := NowOptions + [idoHardware];
		3456
		3457	D3DDevice2 := D3DDevice3 as IDirect3DDevice2;
		3458	D3DDevice := D3DDevice3 as IDirect3DDevice;
		3459
		3460	with D3DDevice3 do
		3461	begin
		3462	SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_DITHERENABLE), 1);
		3463	SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZENABLE), Ord(ZBuffer<>nil));
		3464	SetRenderState(TD3DRenderStateType(D3DRENDERSTATE_ZWRITEENABLE), Ord(ZBuffer<>nil));
		3465	end;
		3466
		3467	{ Direct3D Retained Mode}
		3468	if idoRetainedMode in Options then
		3469	begin
		3470	NowOptions := NowOptions + [idoRetainedMode];
		3471
		3472	if D3DRM=nil then
		3473	begin
		3474	if TDirect3DRMCreate(DXLoadLibrary('D3DRM.dll', 'Direct3DRMCreate'))(D3DRM)<>D3DRM_OK then
		3475	raise EDXDrawError.CreateFmt(SCannotInitialized, [SDirect3DRM]);
		3476	D3DRM2 := D3DRM as IDirect3DRM2;
		3477	D3DRM3 := D3DRM as IDirect3DRM3;
		3478	end;
		3479
		3480	if D3DRM3.CreateDeviceFromD3D(D3D2, D3DDevice2, D3DRMDevice3)<>D3DRM_OK then
		3481	raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DRMDevice2']);
		3482
		3483	D3DRMDevice3.SetBufferCount(2);
		3484	D3DRMDevice := D3DRMDevice3 as IDirect3DRMDevice;
		3485	D3DRMDevice2 := D3DRMDevice3 as IDirect3DRMDevice2;
		3486
		3487	{ Rendering state setting }
		3488	D3DRMDevice.SetQuality(D3DRMLIGHT_ON or D3DRMFILL_SOLID or D3DRMSHADE_GOURAUD);
		3489	D3DRMDevice.SetTextureQuality(D3DRMTEXTURE_NEAREST);
		3490	D3DRMDevice.SetDither(True);
		3491
		3492	if Surface.BitCount=8 then
		3493	begin
		3494	D3DRMDevice.SetShades(8);
		3495	D3DRM.SetDefaultTextureColors(64);
		3496	D3DRM.SetDefaultTextureShades(32);
		3497	end else
		3498	begin
		3499	D3DRM.SetDefaultTextureColors(64);
		3500	D3DRM.SetDefaultTextureShades(32);
		3501	end;
		3502
		3503	{ Frame making }
		3504	if Scene=nil then
		3505	begin
		3506	D3DRM.CreateFrame(nil, Scene);
		3507	D3DRM.CreateFrame(Scene, Camera);
		3508	Camera.SetPosition(Camera, 0, 0, 0);
		3509	end;
		3510
		3511	{ Viewport making }
		3512	D3DRM.CreateViewport(D3DRMDevice, Camera, 0, 0,
		3513	Surface.Width, Surface.Height, Viewport);
		3514	Viewport.SetBack(5000.0);
		3515	end;
		3516	except
		3517	FreeZBufferSurface(Surface, ZBuffer);
		3518	D3D := nil;
		3519	D3D2 := nil;
		3520	D3D3 := nil;
		3521	D3DDevice := nil;
		3522	D3DDevice2 := nil;
		3523	D3DDevice3 := nil;
		3524	D3DRM := nil;
		3525	D3DRM2 := nil;
		3526	D3DRMDevice := nil;
		3527	D3DRMDevice2 := nil;
		3528	Viewport := nil;
		3529	Scene := nil;
		3530	Camera := nil;
		3531	raise;
		3532	end;
		3533	end;
		3534
		3535	procedure InitializeDirect3D7(Surface: TDirectDrawSurface;
		3536	var ZBuffer: TDirectDrawSurface;
		3537	out D3D7: IDirect3D7;
		3538	out D3DDevice7: IDirect3DDevice7;
		3539	var NowOptions: TInitializeDirect3DOptions);
		3540	type
		3541	TInitializeDirect3DRecord = record
		3542	Flag: Boolean;
		3543	BitCount: Integer;
		3544	DeviceDesc: TD3DDeviceDesc7;
		3545	Hardware: Boolean;
		3546	Options: TInitializeDirect3DOptions;
		3547	SupportHardware: Boolean;
		3548	end;
		3549
		3550	function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
		3551	const DeviceDesc: TD3DDeviceDesc7; Hardware: Boolean): Boolean;
		3552	const
		3553	MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
		3554	var
		3555	ZBufferBitDepth: Integer;
		3556	ddsd: TDDSurfaceDesc;
		3557	begin
		3558	Result := False;
		3559	FreeZBufferSurface(Surface, ZBuffer);
		3560
		3561	if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16<>0 then
		3562	ZBufferBitDepth := 16
		3563	else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24<>0 then
		3564	ZBufferBitDepth := 24
		3565	else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32<>0 then
		3566	ZBufferBitDepth := 32
		3567	else
		3568	ZBufferBitDepth := 0;
		3569
		3570	if ZBufferBitDepth<>0 then
		3571	begin
		3572	with ddsd do
		3573	begin
		3574	dwSize := SizeOf(ddsd);
		3575	Surface.ISurface.GetSurfaceDesc(ddsd);
		3576	dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
		3577	ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
		3578	dwHeight := Surface.Height;
		3579	dwWidth := Surface.Width;
		3580	dwZBufferBitDepth := ZBufferBitDepth;
		3581	end;
		3582
		3583	ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
		3584	if ZBuffer.CreateSurface(ddsd) then
		3585	begin
		3586	if Surface.ISurface.AddAttachedSurface(ZBuffer.ISurface)<>DD_OK then
		3587	begin
		3588	ZBuffer.Free; ZBuffer := nil;
		3589	Exit;
		3590	end;
		3591	Result := True;
		3592	end else
		3593	begin
		3594	ZBuffer.Free; ZBuffer := nil;
		3595	Exit;
		3596	end;
		3597	end;
		3598	end;
		3599
		3600	function EnumDeviceCallBack(lpDeviceDescription, lpDeviceName: PChar;
		3601	const lpTD3DDeviceDesc: TD3DDeviceDesc7; lpUserArg: Pointer): HRESULT; stdcall;
		3602	var
		3603	Hardware: Boolean;
		3604	rec: ^TInitializeDirect3DRecord;
		3605
		3606	procedure UseThisDevice;
		3607	begin
		3608	rec.Flag := True;
		3609	rec.DeviceDesc := lpTD3DDeviceDesc;
		3610	rec.Hardware := Hardware;
		3611	end;
		3612
		3613	begin
		3614	Result := D3DENUMRET_OK;
		3615	rec := lpUserArg;
		3616
		3617	Hardware := lpTD3DDeviceDesc.dwDevCaps and D3DDEVCAPS_HWRASTERIZATION<>0;
		3618
		3619	if Hardware and (not rec.SupportHardware) then Exit;
		3620	if CompareMem(@lpTD3DDeviceDesc.deviceGUID, @IID_IDirect3DRefDevice, SizeOf(TGUID)) then Exit;
		3621
		3622	{ Bit depth test. }
		3623	if (lpTD3DDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then Exit;
		3624
		3625	if Hardware then
		3626	begin
		3627	{ Hardware }
		3628	UseThisDevice;
		3629	end else
		3630	begin
		3631	{ Software }
		3632	if not rec.Hardware then
		3633	UseThisDevice;
		3634	end;
		3635	end;
		3636
		3637	var
		3638	Hardware: Boolean;
		3639	SupportHardware: Boolean;
		3640	D3DDeviceGUID: TGUID;
		3641	Options: TInitializeDirect3DOptions;
		3642
		3643	procedure InitDevice;
		3644	var
		3645	rec: TInitializeDirect3DRecord;
		3646	begin
		3647	{ Device search }
		3648	rec.Flag := False;
		3649	rec.BitCount := Surface.BitCount;
		3650	rec.Hardware := False;
		3651	rec.Options := Options;
		3652	rec.SupportHardware := SupportHardware;
		3653
		3654	D3D7.EnumDevices(@EnumDeviceCallBack, @rec);
		3655	if not rec.Flag then
		3656	raise EDXDrawError.Create(S3DDeviceNotFound);
		3657
		3658	Hardware := rec.Hardware;
		3659	D3DDeviceGUID := rec.DeviceDesc.deviceGUID;
		3660
		3661	if Hardware then
		3662	NowOptions := NowOptions + [idoHardware];
		3663
		3664	{ Z buffer making }
		3665	NowOptions := NowOptions - [idoZBuffer];
		3666	if idoZBuffer in Options then
		3667	begin
		3668	if CreateZBufferSurface(Surface, ZBuffer, rec.DeviceDesc, Hardware) then
		3669	NowOptions := NowOptions + [idoZBuffer];
		3670	end;
		3671	end;
		3672
		3673	begin
		3674	try
		3675	Options := NowOptions - [idoRetainedMode];
		3676	NowOptions := [];
		3677
		3678	D3D7 := Surface.DDraw.IDraw7 as IDirect3D7;
		3679
		3680	{ Whether hardware can be used is tested. }
		3681	SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY<>0) and
		3682	(idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D<>0);
		3683
		3684	if Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE=0 then
		3685	SupportHardware := False;
		3686
		3687	{ Direct3D }
		3688	InitDevice;
		3689
		3690	if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7)<>D3D_OK then
		3691	begin
		3692	SupportHardware := False;
		3693	InitDevice;
		3694	if D3D7.CreateDevice(D3DDeviceGUID, Surface.ISurface7, D3DDevice7)<>D3D_OK then
		3695	raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice7']);
		3696	end;
		3697
		3698	if SupportHardware then NowOptions := NowOptions + [idoHardware];
		3699	except
		3700	FreeZBufferSurface(Surface, ZBuffer);
		3701	D3D7 := nil;
		3702	D3DDevice7 := nil;
		3703	raise;
		3704	end;
		3705	end;
		3706
		3707	type
		3708	{ TDXDrawDriver }
		3709
		3710	TDXDrawDriver = class
		3711	private
		3712	FDXDraw: TCustomDXDraw;
		3713	constructor Create(ADXDraw: TCustomDXDraw); virtual;
		3714	destructor Destroy; override;
		3715	procedure Finalize; virtual;
		3716	procedure Flip; virtual; abstract;
		3717	procedure Initialize; virtual; abstract;
		3718	procedure Initialize3D;
		3719	function SetSize(AWidth, AHeight: Integer): Boolean; virtual;
		3720	function Restore: Boolean;
		3721	end;
		3722
		3723	TDXDrawDriverBlt = class(TDXDrawDriver)
		3724	private
		3725	procedure Flip; override;
		3726	procedure Initialize; override;
		3727	procedure InitializeSurface;
		3728	function SetSize(AWidth, AHeight: Integer): Boolean; override;
		3729	end;
		3730
		3731	TDXDrawDriverFlip = class(TDXDrawDriver)
		3732	private
		3733	procedure Flip; override;
		3734	procedure Initialize; override;
		3735	end;
		3736
		3737	{ TDXDrawDriver }
		3738
		3739	constructor TDXDrawDriver.Create(ADXDraw: TCustomDXDraw);
		3740	var
		3741	AOptions: TInitializeDirect3DOptions;
		3742	begin
		3743	inherited Create;
		3744	FDXDraw := ADXDraw;
		3745
		3746	{ Driver selection and Display mode optimizationn }
		3747	if FDXDraw.FOptions*[doFullScreen, doSystemMemory, do3D, doHardware]=
		3748	[doFullScreen, do3D, doHardware] then
		3749	begin
		3750	AOptions := [];
		3751	with FDXDraw do
		3752	begin
		3753	if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
		3754	if not FDXDraw.Display.FixedBitCount then AOptions := AOptions + [idoOptimizeDisplayMode];
		3755
		3756	if doHardware in Options then AOptions := AOptions + [idoHardware];
		3757	if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
		3758	if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
		3759	end;
		3760
		3761	Direct3DInitializing_DXDraw(AOptions, FDXDraw);
		3762	end;
		3763
		3764	if FDXDraw.Options*[doFullScreen, doHardware, doSystemMemory]=[doFullScreen, doHardware] then
		3765	FDXDraw.FDDraw := TDirectDraw.CreateEx(PGUID(FDXDraw.FDriver), doDirectX7Mode in FDXDraw.Options)
		3766	else
		3767	FDXDraw.FDDraw := TDirectDraw.CreateEx(nil, doDirectX7Mode in FDXDraw.Options);
		3768	end;
		3769
		3770	procedure TDXDrawDriver.Initialize3D;
		3771	const
		3772	DXDrawOptions3D = [doHardware, doRetainedMode, doSelectDriver, doZBuffer];
		3773	var
		3774	AOptions: TInitializeDirect3DOptions;
		3775	begin
		3776	AOptions := [];
		3777	with FDXDraw do
		3778	begin
		3779	if doHardware in FOptions then AOptions := AOptions + [idoHardware];
		3780	if doRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
		3781	if doSelectDriver in FOptions then AOptions := AOptions + [idoSelectDriver];
		3782	if doZBuffer in FOptions then AOptions := AOptions + [idoZBuffer];
		3783
		3784	if doDirectX7Mode in FOptions then
		3785	begin
		3786	InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
		3787	end else
		3788	begin
		3789	InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
		3790	FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera, AOptions);
		3791	end;
		3792
		3793	FNowOptions := FNowOptions - DXDrawOptions3D;
		3794	if idoHardware in AOptions then FNowOptions := FNowOptions + [doHardware];
		3795	if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [doRetainedMode];
		3796	if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [doSelectDriver];
		3797	if idoZBuffer in AOptions then FNowOptions := FNowOptions + [doZBuffer];
		3798	end;
		3799	end;
		3800
		3801	destructor TDXDrawDriver.Destroy;
		3802	begin
		3803	Finalize;
		3804	FDXDraw.FDDraw.Free;
		3805	inherited Destroy;
		3806	end;
		3807
		3808	procedure TDXDrawDriver.Finalize;
		3809	begin
		3810	with FDXDraw do
		3811	begin
		3812	FViewport := nil;
		3813	FCamera := nil;
		3814	FScene := nil;
		3815
		3816	FD3DRMDevice := nil;
		3817	FD3DRMDevice2 := nil;
		3818	FD3DRMDevice3 := nil;
		3819	FD3DDevice := nil;
		3820	FD3DDevice2 := nil;
		3821	FD3DDevice3 := nil;
		3822	FD3DDevice7 := nil;
		3823	FD3D := nil;
		3824	FD3D2 := nil;
		3825	FD3D3 := nil;
		3826	FD3D7 := nil;
		3827
		3828	FreeZBufferSurface(FSurface, FZBuffer);
		3829
		3830	FClipper.Free; FClipper := nil;
		3831	FPalette.Free; FPalette := nil;
		3832	FSurface.Free; FSurface := nil;
		3833	FPrimary.Free; FPrimary := nil;
		3834
		3835	FD3DRM3 := nil;
		3836	FD3DRM2 := nil;
		3837	FD3DRM := nil;
		3838	end;
		3839	end;
		3840
		3841	function TDXDrawDriver.Restore: Boolean;
		3842	begin
		3843	Result := FDXDraw.FPrimary.Restore and FDXDraw.FSurface.Restore;
		3844	if Result then
		3845	begin
		3846	FDXDraw.FPrimary.Fill(0);
		3847	FDXDraw.FSurface.Fill(0);
		3848	end;
		3849	end;
		3850
		3851	function TDXDrawDriver.SetSize(AWidth, AHeight: Integer): Boolean;
		3852	begin
		3853	Result := False;
		3854	end;
		3855
		3856	{ TDXDrawDriverBlt }
		3857
		3858	function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
		3859	AllowPalette256: Boolean): TPaletteEntries;
		3860	var
		3861	Entries: TPaletteEntries;
		3862	dc: THandle;
		3863	i: Integer;
		3864	begin
		3865	Result := RGBQuadsToPaletteEntries(RGBQuads);
		3866
		3867	if not AllowPalette256 then
		3868	begin
		3869	dc := GetDC(0);
		3870	GetSystemPaletteEntries(dc, 0, 256, Entries);
		3871	ReleaseDC(0, dc);
		3872
		3873	for i:=0 to 9 do
		3874	Result[i] := Entries[i];
		3875
		3876	for i:=256-10 to 255 do
		3877	Result[i] := Entries[i];
		3878	end;
		3879
		3880	for i:=0 to 255 do
		3881	Result[i].peFlags := D3DPAL_READONLY;
		3882	end;
		3883
		3884	procedure TDXDrawDriverBlt.Flip;
		3885	var
		3886	pt: TPoint;
		3887	Dest: TRect;
		3888	DF: TDDBltFX;
		3889	begin
		3890	pt := FDXDraw.ClientToScreen(Point(0, 0));
		3891
		3892	if doStretch in FDXDraw.NowOptions then
		3893	begin
		3894	Dest := Bounds(pt.x, pt.y, FDXDraw.Width, FDXDraw.Height);
		3895	end else
		3896	begin
		3897	if doCenter in FDXDraw.NowOptions then
		3898	begin
		3899	Inc(pt.x, (FDXDraw.Width-FDXDraw.FSurface.Width) div 2);
		3900	Inc(pt.y, (FDXDraw.Height-FDXDraw.FSurface.Height) div 2);
		3901	end;
		3902
		3903	Dest := Bounds(pt.x, pt.y, FDXDraw.FSurface.Width, FDXDraw.FSurface.Height);
		3904	end;
		3905
		3906	if doWaitVBlank in FDXDraw.NowOptions then
		3907	FDXDraw.FDDraw.DXResult := FDXDraw.FDDraw.IDraw.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
		3908
		3909	DF.dwsize := SizeOf(DF);
		3910	DF.dwDDFX := 0;
		3911
		3912	FDXDraw.FPrimary.Blt(Dest, FDXDraw.FSurface.ClientRect, DDBLT_WAIT, df, FDXDraw.FSurface);
		3913	end;
		3914
		3915	procedure TDXDrawDriverBlt.Initialize;
		3916	const
		3917	PrimaryDesc: TDDSurfaceDesc = (
		3918	dwSize: SizeOf(PrimaryDesc);
		3919	dwFlags: DDSD_CAPS;
		3920	ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
		3921	);
		3922	var
		3923	Entries: TPaletteEntries;
		3924	PaletteCaps: Integer;
		3925	begin
		3926	{ Surface making }
		3927	FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
		3928	if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
		3929	raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
		3930
		3931	FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
		3932
		3933	{ Clipper making }
		3934	FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
		3935	FDXDraw.FClipper.Handle := FDXDraw.Handle;
		3936	FDXDraw.FPrimary.Clipper := FDXDraw.FClipper;
		3937
		3938	{ Palette making }
		3939	PaletteCaps := DDPCAPS_8BIT or DDPCAPS_INITIALIZE;
		3940	if doAllowPalette256 in FDXDraw.NowOptions then
		3941	PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
		3942
		3943	FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
		3944	Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
		3945	doAllowPalette256 in FDXDraw.NowOptions);
		3946	FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
		3947
		3948	FDXDraw.FPrimary.Palette := FDXDraw.Palette;
		3949
		3950	InitializeSurface;
		3951	end;
		3952
		3953	procedure TDXDrawDriverBlt.InitializeSurface;
		3954	var
		3955	ddsd: TDDSurfaceDesc;
		3956	begin
		3957	FDXDraw.FSurface.IDDSurface := nil;
		3958
		3959	{ Surface making }
		3960	FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
		3961
		3962	FillChar(ddsd, SizeOf(ddsd), 0);
		3963	with ddsd do
		3964	begin
		3965	dwSize := SizeOf(ddsd);
		3966	dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
		3967	dwWidth := Max(FDXDraw.FSurfaceWidth, 1);
		3968	dwHeight := Max(FDXDraw.FSurfaceHeight, 1);
		3969	ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
		3970	if doSystemMemory in FDXDraw.Options then
		3971	ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
		3972	if do3D in FDXDraw.FNowOptions then
		3973	ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
		3974	end;
		3975
		3976	if not FDXDraw.FSurface.CreateSurface(ddsd) then
		3977	begin
		3978	ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
		3979	if not FDXDraw.FSurface.CreateSurface(ddsd) then
		3980	raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
		3981	end;
		3982
		3983	if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY=0 then
		3984	FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
		3985
		3986	FDXDraw.FSurface.Palette := FDXDraw.Palette;
		3987	FDXDraw.FSurface.Fill(0);
		3988
		3989	if do3D in FDXDraw.FNowOptions then
		3990	Initialize3D;
		3991	end;
		3992
		3993	function TDXDrawDriverBlt.SetSize(AWidth, AHeight: Integer): Boolean;
		3994	begin
		3995	Result := True;
		3996
		3997	FDXDraw.FSurfaceWidth := Max(AWidth, 1);
		3998	FDXDraw.FSurfaceHeight := Max(AHeight, 1);
		3999
		4000	Inc(FDXDraw.FOffNotifyRestore);
		4001	try
		4002	FDXDraw.NotifyEventList(dxntFinalizeSurface);
		4003
		4004	if FDXDraw.FCalledDoInitializeSurface then
		4005	begin
		4006	FDXDraw.FCalledDoInitializeSurface := False;
		4007	FDXDraw.DoFinalizeSurface;
		4008	end;
		4009
		4010	InitializeSurface;
		4011
		4012	FDXDraw.NotifyEventList(dxntInitializeSurface);
		4013	FDXDraw.FCalledDoInitializeSurface := True; FDXDraw.DoInitializeSurface;
		4014	finally
		4015	Dec(FDXDraw.FOffNotifyRestore);
		4016	end;
		4017	end;
		4018
		4019	{ TDXDrawDriverFlip }
		4020
		4021	procedure TDXDrawDriverFlip.Flip;
		4022	begin
		4023	if (FDXDraw.FForm<>nil) and (FDXDraw.FForm.Active) then
		4024	FDXDraw.FPrimary.DXResult := FDXDraw.FPrimary.ISurface.Flip(nil, DDFLIP_WAIT)
		4025	else
		4026	FDXDraw.FPrimary.DXResult := 0;
		4027	end;
		4028
		4029	procedure TDXDrawDriverFlip.Initialize;
		4030	const
		4031	DefPrimaryDesc: TDDSurfaceDesc = (
		4032	dwSize: SizeOf(DefPrimaryDesc);
		4033	dwFlags: DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
		4034	dwBackBufferCount: 1;
		4035	ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX)
		4036	);
		4037	BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
		4038	var
		4039	PrimaryDesc: TDDSurfaceDesc;
		4040	PaletteCaps: Integer;
		4041	Entries: TPaletteEntries;
		4042	DDSurface: IDirectDrawSurface;
		4043	begin
		4044	{ Surface making }
		4045	PrimaryDesc := DefPrimaryDesc;
		4046
		4047	if do3D in FDXDraw.FNowOptions then
		4048	PrimaryDesc.ddsCaps.dwCaps := PrimaryDesc.ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
		4049
		4050	FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
		4051	if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
		4052	raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
		4053
		4054	FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
		4055	if FDXDraw.FPrimary.ISurface.GetAttachedSurface(BackBufferCaps, DDSurface)=DD_OK then
		4056	FDXDraw.FSurface.IDDSurface := DDSurface;
		4057
		4058	FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
		4059	if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_SYSTEMMEMORY<>0 then
		4060	FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
		4061
		4062	{ Clipper making of dummy }
		4063	FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
		4064
		4065	{ Palette making }
		4066	PaletteCaps := DDPCAPS_8BIT;
		4067	if doAllowPalette256 in FDXDraw.Options then
		4068	PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
		4069
		4070	FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
		4071	Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
		4072	doAllowPalette256 in FDXDraw.NowOptions);
		4073	FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
		4074
		4075	FDXDraw.FPrimary.Palette := FDXDraw.Palette;
		4076	FDXDraw.FSurface.Palette := FDXDraw.Palette;
		4077
		4078	if do3D in FDXDraw.FNowOptions then
		4079	Initialize3D;
		4080	end;
		4081
		4082	constructor TCustomDXDraw.Create(AOwner: TComponent);
		4083	var
		4084	Entries: TPaletteEntries;
		4085	dc: THandle;
		4086	begin
		4087	FNotifyEventList := TList.Create;
		4088	inherited Create(AOwner);
		4089	FAutoInitialize := True;
		4090	FDisplay := TDXDrawDisplay.Create(Self);
		4091
		4092	Options := [doAllowReboot, doWaitVBlank, doCenter, doDirectX7Mode, doHardware, doSelectDriver];
		4093
		4094	FAutoSize := True;
		4095
		4096	dc := GetDC(0);
		4097	GetSystemPaletteEntries(dc, 0, 256, Entries);
		4098	ReleaseDC(0, dc);
		4099
		4100	ColorTable := PaletteEntriesToRGBQuads(Entries);
		4101	DefColorTable := ColorTable;
		4102
		4103	Width := 100;
		4104	Height := 100;
		4105	ParentColor := False;
		4106	Color := clBtnFace;
		4107	end;
		4108
		4109	destructor TCustomDXDraw.Destroy;
		4110	begin
		4111	Finalize;
		4112	NotifyEventList(dxntDestroying);
		4113	FDisplay.Free;
		4114	FSubClass.Free; FSubClass := nil;
		4115	FNotifyEventList.Free;
		4116	inherited Destroy;
		4117	end;
		4118
		4119	class function TCustomDXDraw.Drivers: TDirectXDrivers;
		4120	begin
		4121	Result := EnumDirectDrawDrivers;
		4122	end;
		4123
		4124	type
		4125	PDXDrawNotifyEvent = ^TDXDrawNotifyEvent;
		4126
		4127	procedure TCustomDXDraw.RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
		4128	var
		4129	Event: PDXDrawNotifyEvent;
		4130	begin
		4131	UnRegisterNotifyEvent(NotifyEvent);
		4132
		4133	New(Event);
		4134	Event^ := NotifyEvent;
		4135	FNotifyEventList.Add(Event);
		4136
		4137	NotifyEvent(Self, dxntSetSurfaceSize);
		4138
		4139	if Initialized then
		4140	begin
		4141	NotifyEvent(Self, dxntInitialize);
		4142	if FCalledDoInitializeSurface then
		4143	NotifyEvent(Self, dxntInitializeSurface);
		4144	if FOffNotifyRestore=0 then
		4145	NotifyEvent(Self, dxntRestore);
		4146	end;
		4147	end;
		4148
		4149	procedure TCustomDXDraw.UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
		4150	var
		4151	Event: PDXDrawNotifyEvent;
		4152	i: Integer;
		4153	begin
		4154	for i:=0 to FNotifyEventList.Count-1 do
		4155	begin
		4156	Event := FNotifyEventList[i];
		4157	if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
		4158	(TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
		4159	begin
		4160	FreeMem(Event);
		4161	FNotifyEventList.Delete(i);
		4162
		4163	if FCalledDoInitializeSurface then
		4164	NotifyEvent(Self, dxntFinalizeSurface);
		4165	if Initialized then
		4166	NotifyEvent(Self, dxntFinalize);
		4167
		4168	Break;
		4169	end;
		4170	end;
		4171	end;
		4172
		4173	procedure TCustomDXDraw.NotifyEventList(NotifyType: TDXDrawNotifyType);
		4174	var
		4175	i: Integer;
		4176	begin
		4177	for i:=FNotifyEventList.Count-1 downto 0 do
		4178	PDXDrawNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
		4179	end;
		4180
		4181	procedure TCustomDXDraw.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
		4182
		4183	procedure FlipToGDISurface;
		4184	begin
		4185	if Initialized and (FNowOptions*[doFullScreen, doFlip]=[doFullScreen, doFlip]) then
		4186	DDraw.IDraw.FlipToGDISurface;
		4187	end;
		4188
		4189	begin
		4190	case Message.Msg of
		4191	{CM_ACTIVATE:
		4192	begin
		4193	DefWindowProc(Message);
		4194	if AutoInitialize and (not FInitalized2) then
		4195	Initialize;
		4196	Exit;
		4197	end; }
		4198	WM_WINDOWPOSCHANGED:
		4199	begin
		4200	if TWMWindowPosChanged(Message).WindowPos^.flags and SWP_SHOWWINDOW<>0 then
		4201	begin
		4202	DefWindowProc(Message);
		4203	if AutoInitialize and (not FInitialized2) then
		4204	Initialize;
		4205	Exit;
		4206	end;
		4207	end;
		4208	WM_ACTIVATE:
		4209	begin
		4210	if TWMActivate(Message).Active=WA_INACTIVE then
		4211	FlipToGDISurface;
		4212	end;
		4213	WM_INITMENU:
		4214	begin
		4215	FlipToGDISurface;
		4216	end;
		4217	WM_DESTROY:
		4218	begin
		4219	Finalize;
		4220	end;
		4221	end;
		4222	DefWindowProc(Message);
		4223	end;
		4224
		4225	procedure TCustomDXDraw.DoFinalize;
		4226	begin
		4227	if Assigned(FOnFinalize) then FOnFinalize(Self);
		4228	end;
		4229
		4230	procedure TCustomDXDraw.DoFinalizeSurface;
		4231	begin
		4232	if Assigned(FOnFinalizeSurface) then FOnFinalizeSurface(Self);
		4233	end;
		4234
		4235	procedure TCustomDXDraw.DoInitialize;
		4236	begin
		4237	if Assigned(FOnInitialize) then FOnInitialize(Self);
		4238	end;
		4239
		4240	procedure TCustomDXDraw.DoInitializeSurface;
		4241	begin
		4242	if Assigned(FOnInitializeSurface) then FOnInitializeSurface(Self);
		4243	end;
		4244
		4245	procedure TCustomDXDraw.DoInitializing;
		4246	begin
		4247	if Assigned(FOnInitializing) then FOnInitializing(Self);
		4248	end;
		4249
		4250	procedure TCustomDXDraw.DoRestoreSurface;
		4251	begin
		4252	if Assigned(FOnRestoreSurface) then FOnRestoreSurface(Self);
		4253	end;
		4254
		4255	procedure TCustomDXDraw.Finalize;
		4256	begin
		4257	if FInternalInitialized then
		4258	begin
		4259	FSurfaceWidth := SurfaceWidth;
		4260	FSurfaceHeight := SurfaceHeight;
		4261
		4262	FDisplay.FModes.Clear;
		4263
		4264	FUpdating := True;
		4265	try
		4266	try
		4267	try
		4268	if FCalledDoInitializeSurface then
		4269	begin
		4270	FCalledDoInitializeSurface := False;
		4271	DoFinalizeSurface;
		4272	end;
		4273	finally
		4274	NotifyEventList(dxntFinalizeSurface);
		4275	end;
		4276	finally
		4277	try
		4278	if FCalledDoInitialize then
		4279	begin
		4280	FCalledDoInitialize := False;
		4281	DoFinalize;
		4282	end;
		4283	finally
		4284	NotifyEventList(dxntFinalize);
		4285	end;
		4286	end;
		4287	finally
		4288	FInternalInitialized := False;
		4289	FInitialized := False;
		4290
		4291	SetOptions(FOptions);
		4292
		4293	FDXDrawDriver.Free; FDXDrawDriver := nil;
		4294	FUpdating := False;
		4295	end;
		4296	end;
		4297	end;
		4298
		4299	procedure TCustomDXDraw.Flip;
		4300	begin
		4301	if Initialized and (not FUpdating) then
		4302	begin
		4303	if TryRestore then
		4304	TDXDrawDriver(FDXDrawDriver).Flip;
		4305	end;
		4306	end;
		4307
		4308	function TCustomDXDraw.GetCanDraw: Boolean;
		4309	begin
		4310	Result := Initialized and (not FUpdating) and (Surface.IDDSurface<>nil) and
		4311	TryRestore;
		4312	end;
		4313
		4314	function TCustomDXDraw.GetCanPaletteAnimation: Boolean;
		4315	begin
		4316	Result := Initialized and (not FUpdating) and (doFullScreen in FNowOptions)
		4317	and (DDraw.DisplayMode.ddpfPixelFormat.dwRGBBitCount<=8);
		4318	end;
		4319
		4320	function TCustomDXDraw.GetSurfaceHeight: Integer;
		4321	begin
		4322	if Surface.IDDSurface<>nil then
		4323	Result := Surface.Height
		4324	else
		4325	Result := FSurfaceHeight;
		4326	end;
		4327
		4328	function TCustomDXDraw.GetSurfaceWidth: Integer;
		4329	begin
		4330	if Surface.IDDSurface<>nil then
		4331	Result := Surface.Width
		4332	else
		4333	Result := FSurfaceWidth;
		4334	end;
		4335
		4336	procedure TCustomDXDraw.Loaded;
		4337	begin
		4338	inherited Loaded;
		4339
		4340	if AutoSize then
		4341	begin
		4342	FSurfaceWidth := Width;
		4343	FSurfaceHeight := Height;
		4344	end;
		4345
		4346	NotifyEventList(dxntSetSurfaceSize);
		4347
		4348	if FAutoInitialize and (not (csDesigning in ComponentState)) then
		4349	begin
		4350	if {(not (doFullScreen in FOptions)) or }(FSubClass=nil) then
		4351	Initialize;
		4352	end;
		4353	end;
		4354
		4355	procedure TCustomDXDraw.Initialize;
		4356	begin
		4357	FInitialized2 := True;
		4358
		4359	Finalize;
		4360
		4361	if FForm=nil then
		4362	raise EDXDrawError.Create(SNoForm);
		4363
		4364	try
		4365	DoInitializing;
		4366
		4367	{ Initialization. }
		4368	FUpdating := True;
		4369	try
		4370	FInternalInitialized := True;
		4371
		4372	NotifyEventList(dxntInitializing);
		4373
		4374	{ DirectDraw initialization. }
		4375	if doFlip in FNowOptions then
		4376	FDXDrawDriver := TDXDrawDriverFlip.Create(Self)
		4377	else
		4378	FDXDrawDriver := TDXDrawDriverBlt.Create(Self);
		4379
		4380	{ Window handle setting. }
		4381	SetCooperativeLevel;
		4382
		4383	{ Set display mode. }
		4384	if doFullScreen in FNowOptions then
		4385	begin
		4386	if not Display.DynSetSize(Display.Width, Display.Height, Display.BitCount) then
		4387	raise EDXDrawError.CreateFmt(SDisplaymodeChange, [Display.Width, Display.Height, Display.BitCount]);
		4388	end;
		4389
		4390	{ Resource initialization. }
		4391	if AutoSize then
		4392	begin
		4393	FSurfaceWidth := Width;
		4394	FSurfaceHeight := Height;
		4395	end;
		4396
		4397	TDXDrawDriver(FDXDrawDriver).Initialize;
		4398	finally
		4399	FUpdating := False;
		4400	end;
		4401	except
		4402	Finalize;
		4403	raise;
		4404	end;
		4405
		4406	FInitialized := True;
		4407
		4408	Inc(FOffNotifyRestore);
		4409	try
		4410	NotifyEventList(dxntSetSurfaceSize);
		4411	NotifyEventList(dxntInitialize);
		4412	FCalledDoInitialize := True; DoInitialize;
		4413
		4414	NotifyEventList(dxntInitializeSurface);
		4415	FCalledDoInitializeSurface := True; DoInitializeSurface;
		4416	finally
		4417	Dec(FOffNotifyRestore);
		4418	end;
		4419
		4420	Restore;
		4421	end;
		4422
		4423	procedure TCustomDXDraw.Paint;
		4424	var
		4425	Old: TDXDrawOptions;
		4426	w, h: Integer;
		4427	s: string;
		4428	begin
		4429	inherited Paint;
		4430	if (csDesigning in ComponentState) then
		4431	begin
		4432	Canvas.Brush.Style := bsClear;
		4433	Canvas.Pen.Color := clBlack;
		4434	Canvas.Pen.Style := psDash;
		4435	Canvas.Rectangle(0, 0, Width, Height);
		4436
		4437	Canvas.Pen.Style := psSolid;
		4438	Canvas.Pen.Color := clGray;
		4439	Canvas.MoveTo(0, 0);
		4440	Canvas.LineTo(Width, Height);
		4441
		4442	Canvas.MoveTo(0, Height);
		4443	Canvas.LineTo(Width, 0);
		4444
		4445	s := Format('(%s)', [ClassName]);
		4446
		4447	w := Canvas.TextWidth(s);
		4448	h := Canvas.TextHeight(s);
		4449
		4450	Canvas.Brush.Style := bsSolid;
		4451	Canvas.Brush.Color := clBtnFace;
		4452	Canvas.TextOut(Width div 2-w div 2, Height div 2-h div 2, s);
		4453	end else
		4454	begin
		4455	Old := FNowOptions;
		4456	try
		4457	FNowOptions := FNowOptions - [doWaitVBlank];
		4458	Flip;
		4459	finally
		4460	FNowOptions := Old;
		4461	end;
		4462	if (Parent<>nil) and (Initialized) and (Surface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY<>0) then
		4463	Parent.Invalidate;
		4464	end;
		4465	end;
		4466
		4467	function TCustomDXDraw.PaletteChanged(Foreground: Boolean): Boolean;
		4468	begin
		4469	if Foreground then
		4470	begin
		4471	Restore;
		4472	Result := True;
		4473	end else
		4474	Result := False;
		4475	end;
		4476
		4477	procedure TCustomDXDraw.Render;
		4478	begin
		4479	if FInitialized and (do3D in FNowOptions) and (doRetainedMode in FNowOptions) then
		4480	begin
		4481	asm FInit end;
		4482	FViewport.Clear;
		4483	FViewport.Render(FScene);
		4484	FD3DRMDevice.Update;
		4485	asm FInit end;
		4486	end;
		4487	end;
		4488
		4489	procedure TCustomDXDraw.Restore;
		4490	begin
		4491	if Initialized and (not FUpdating) then
		4492	begin
		4493	FUpdating := True;
		4494	try
		4495	if TDXDrawDriver(FDXDrawDriver).Restore then
		4496	begin
		4497	Primary.Palette := Palette;
		4498	Surface.Palette := Palette;
		4499
		4500	SetColorTable(DefColorTable);
		4501	NotifyEventList(dxntRestore);
		4502	DoRestoreSurface;
		4503	SetColorTable(ColorTable);
		4504	end;
		4505	finally
		4506	FUpdating := False;
		4507	end;
		4508	end;
		4509	end;
		4510
		4511	procedure TCustomDXDraw.SetAutoSize(Value: Boolean);
		4512	begin
		4513	if FAutoSize<>Value then
		4514	begin
		4515	FAutoSize := Value;
		4516	if FAutoSize then
		4517	SetSize(Width, Height);
		4518	end;
		4519	end;
		4520
		4521	procedure TCustomDXDraw.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
		4522	begin
		4523	inherited SetBounds(ALeft, ATop, AWidth, AHeight);
		4524	if FAutoSize and (not FUpdating) then
		4525	SetSize(AWidth, AHeight);
		4526	end;
		4527
		4528	procedure TCustomDXDraw.SetColorTable(const ColorTable: TRGBQuads);
		4529	var
		4530	Entries: TPaletteEntries;
		4531	begin
		4532	if Initialized and (Palette<>nil) then
		4533	begin
		4534	Entries := TDXDrawRGBQuadsToPaletteEntries(ColorTable,
		4535	doAllowPalette256 in FNowOptions);
		4536	Palette.SetEntries(0, 256, Entries);
		4537	end;
		4538	end;
		4539
		4540	procedure TCustomDXDraw.SetCooperativeLevel;
		4541	var
		4542	Flags: Integer;
		4543	Control: TWinControl;
		4544	begin
		4545	Control := FForm;
		4546	if Control=nil then
		4547	Control := Self;
		4548
		4549	if doFullScreen in FNowOptions then
		4550	begin
		4551	Flags := DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE or DDSCL_ALLOWMODEX;
		4552	if doNoWindowChange in FNowOptions then
		4553	Flags := Flags or DDSCL_NOWINDOWCHANGES;
		4554	if doAllowReboot in FNowOptions then
		4555	Flags := Flags or DDSCL_ALLOWREBOOT;
		4556	end else
		4557	Flags := DDSCL_NORMAL;
		4558
		4559	DDraw.DXResult := DDraw.IDraw.SetCooperativeLevel(Control.Handle, Flags);
		4560	end;
		4561
		4562	procedure TCustomDXDraw.SetDisplay(Value: TDXDrawDisplay);
		4563	begin
		4564	FDisplay.Assign(Value);
		4565	end;
		4566
		4567	procedure TCustomDXDraw.SetDriver(Value: PGUID);
		4568	begin
		4569	if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
		4570	begin
		4571	FDriverGUID := Value^;
		4572	FDriver := @FDriverGUID;
		4573	end else
		4574	FDriver := Value;
		4575	end;
		4576
		4577	procedure TCustomDXDraw.SetOptions(Value: TDXDrawOptions);
		4578	const
		4579	InitOptions = [doDirectX7Mode, doFullScreen, doNoWindowChange, doAllowReboot,
		4580	doAllowPalette256, doSystemMemory, doFlip, do3D,
		4581	doRetainedMode, doHardware, doSelectDriver, doZBuffer];
		4582	var
		4583	OldOptions: TDXDrawOptions;
		4584	begin
		4585	FOptions := Value;
		4586
		4587	if Initialized then
		4588	begin
		4589	OldOptions := FNowOptions;
		4590	FNowOptions := FNowOptions*InitOptions+(FOptions-InitOptions);
		4591
		4592	if not (do3D in FNowOptions) then
		4593	FNowOptions := FNowOptions - [doHardware, doRetainedMode, doSelectDriver, doZBuffer];
		4594	end else
		4595	begin
		4596	FNowOptions := FOptions;
		4597
		4598	if not (doFullScreen in FNowOptions) then
		4599	FNowOptions := FNowOptions - [doNoWindowChange, doAllowReBoot, doAllowPalette256, doFlip];
		4600
		4601	if not (do3D in FNowOptions) then
		4602	FNowOptions := FNowOptions - [doDirectX7Mode, doRetainedMode, doHardware, doSelectDriver, doZBuffer];
		4603
		4604	if doSystemMemory in FNowOptions then
		4605	FNowOptions := FNowOptions - [doFlip];
		4606
		4607	if doDirectX7Mode in FNowOptions then
		4608	FNowOptions := FNowOptions - [doRetainedMode];
		4609
		4610	FNowOptions := FNowOptions - [doHardware];
		4611	end;
		4612	end;
		4613
		4614	procedure TCustomDXDraw.SetParent(AParent: TWinControl);
		4615	var
		4616	Control: TWinControl;
		4617	begin
		4618	inherited SetParent(AParent);
		4619
		4620	FForm := nil;
		4621	FSubClass.Free; FSubClass := nil;
		4622
		4623	if not (csDesigning in ComponentState) then
		4624	begin
		4625	Control := Parent;
		4626	while (Control<>nil) and (not (Control is TCustomForm)) do
		4627	Control := Control.Parent;
		4628	if Control<>nil then
		4629	begin
		4630	FForm := TCustomForm(Control);
		4631	FSubClass := TControlSubClass.Create(Control, FormWndProc);
		4632	end;
		4633	end;
		4634	end;
		4635
		4636	procedure TCustomDXDraw.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
		4637	begin
		4638	if ((ASurfaceWidth<>SurfaceWidth) or (ASurfaceHeight<>SurfaceHeight)) and
		4639	(not FUpdating) then
		4640	begin
		4641	if Initialized then
		4642	begin
		4643	try
		4644	if not TDXDrawDriver(FDXDrawDriver).SetSize(ASurfaceWidth, ASurfaceHeight) then
		4645	Exit;
		4646	except
		4647	Finalize;
		4648	raise;
		4649	end;
		4650	end else
		4651	begin
		4652	FSurfaceWidth := ASurfaceWidth;
		4653	FSurfaceHeight := ASurfaceHeight;
		4654	end;
		4655
		4656	NotifyEventList(dxntSetSurfaceSize);
		4657	end;
		4658	end;
		4659
		4660	procedure TCustomDXDraw.SetSurfaceHeight(Value: Integer);
		4661	begin
		4662	if ComponentState*[csReading, csLoading]=[] then
		4663	SetSize(SurfaceWidth, Value)
		4664	else
		4665	FSurfaceHeight := Value;
		4666	end;
		4667
		4668	procedure TCustomDXDraw.SetSurfaceWidth(Value: Integer);
		4669	begin
		4670	if ComponentState*[csReading, csLoading]=[] then
		4671	SetSize(Value, SurfaceHeight)
		4672	else
		4673	FSurfaceWidth := Value;
		4674	end;
		4675
		4676	function TCustomDXDraw.TryRestore: Boolean;
		4677	begin
		4678	Result := False;
		4679
		4680	if Initialized and (not FUpdating) and (Primary.IDDSurface<>nil) then
		4681	begin
		4682	if (Primary.ISurface.IsLost=DDERR_SURFACELOST) or
		4683	(Surface.ISurface.IsLost=DDERR_SURFACELOST) then
		4684	begin
		4685	Restore;
		4686	Result := (Primary.ISurface.IsLost=DD_OK) and (Surface.ISurface.IsLost=DD_OK);
		4687	end else
		4688	Result := True;
		4689	end;
		4690	end;
		4691
		4692	procedure TCustomDXDraw.UpdatePalette;
		4693	begin
		4694	if Initialized and (doWaitVBlank in FNowOptions) then
		4695	begin
		4696	if FDDraw.FDriverCaps.dwPalCaps and DDPCAPS_VSYNC=0 then
		4697	FDDraw.IDraw.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
		4698	end;
		4699
		4700	SetColorTable(ColorTable);
		4701	end;
		4702
		4703	procedure TCustomDXDraw.WMCreate(var Message: TMessage);
		4704	begin
		4705	inherited;
		4706	if Initialized and (not FUpdating) then
		4707	begin
		4708	if Clipper<>nil then
		4709	Clipper.Handle := Handle;
		4710	SetCooperativeLevel;
		4711	end;
		4712	end;
		4713
		4714	{ TCustomDX3D }
		4715
		4716	constructor TCustomDX3D.Create(AOwner: TComponent);
		4717	begin
		4718	inherited Create(AOwner);
		4719	Options := [toHardware, toRetainedMode, toSelectDriver];
		4720	FSurfaceWidth := 320;
		4721	FSurfaceHeight := 240;
		4722	end;
		4723
		4724	destructor TCustomDX3D.Destroy;
		4725	begin
		4726	DXDraw := nil;
		4727	inherited Destroy;
		4728	end;
		4729
		4730	procedure TCustomDX3D.DoFinalize;
		4731	begin
		4732	if Assigned(FOnFinalize) then FOnFinalize(Self);
		4733	end;
		4734
		4735	procedure TCustomDX3D.DoInitialize;
		4736	begin
		4737	if Assigned(FOnInitialize) then FOnInitialize(Self);
		4738	end;
		4739
		4740	procedure TCustomDX3D.Finalize;
		4741	begin
		4742	if FInitialized then
		4743	begin
		4744	try
		4745	if FInitFlag then
		4746	begin
		4747	FInitFlag := False;
		4748	DoFinalize;
		4749	end;
		4750	finally
		4751	FInitialized := False;
		4752
		4753	SetOptions(FOptions);
		4754
		4755	FViewport := nil;
		4756	FCamera := nil;
		4757	FScene := nil;
		4758
		4759	FD3DRMDevice := nil;
		4760	FD3DRMDevice2 := nil;
		4761	FD3DRMDevice3 := nil;
		4762	FD3DDevice := nil;
		4763	FD3DDevice2 := nil;
		4764	FD3DDevice3 := nil;
		4765	FD3DDevice7 := nil;
		4766	FD3D := nil;
		4767	FD3D2 := nil;
		4768	FD3D3 := nil;
		4769	FD3D7 := nil;
		4770
		4771	FreeZBufferSurface(FSurface, FZBuffer);
		4772
		4773	FSurface.Free; FSurface := nil;
		4774
		4775	FD3DRM3 := nil;
		4776	FD3DRM2 := nil;
		4777	FD3DRM := nil;
		4778	end;
		4779	end;
		4780	end;
		4781
		4782	procedure TCustomDX3D.Initialize;
		4783	var
		4784	ddsd: TDDSurfaceDesc;
		4785	AOptions: TInitializeDirect3DOptions;
		4786	begin
		4787	Finalize;
		4788	try
		4789	FInitialized := True;
		4790
		4791	{ Make surface. }
		4792	FillChar(ddsd, SizeOf(ddsd), 0);
		4793	ddsd.dwSize := SizeOf(ddsd);
		4794	ddsd.dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
		4795	ddsd.dwWidth := Max(FSurfaceWidth, 1);
		4796	ddsd.dwHeight := Max(FSurfaceHeight, 1);
		4797	ddsd.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN or DDSCAPS_3DDEVICE;
		4798	if toSystemMemory in FNowOptions then
		4799	ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY
		4800	else
		4801	ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_VIDEOMEMORY;
		4802
		4803	FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
		4804	if not FSurface.CreateSurface(ddsd) then
		4805	begin
		4806	ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY) or DDSCAPS_SYSTEMMEMORY;
		4807	if not FSurface.CreateSurface(ddsd) then
		4808	raise EDX3DError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
		4809	end;
		4810
		4811	AOptions := [];
		4812
		4813	if toHardware in FNowOptions then AOptions := AOptions + [idoHardware];
		4814	if toRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
		4815	if toSelectDriver in FNowOptions then AOptions := AOptions + [idoSelectDriver];
		4816	if toZBuffer in FNowOptions then AOptions := AOptions + [idoZBuffer];
		4817
		4818	if doDirectX7Mode in FDXDraw.NowOptions then
		4819	begin
		4820	InitializeDirect3D7(FSurface, FZBuffer, FD3D7, FD3DDevice7, AOptions);
		4821	end else
		4822	begin
		4823	InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
		4824	FD3DRM, FD3DRM2, FD3DRM3, FD3DRMDevice, FD3DRMDevice2, FD3DRMDevice3, FViewport, FScene, FCamera, AOptions);
		4825	end;
		4826
		4827	FNowOptions := [];
		4828
		4829	if idoHardware in AOptions then FNowOptions := FNowOptions + [toHardware];
		4830	if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [toRetainedMode];
		4831	if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [toSelectDriver];
		4832	if idoZBuffer in AOptions then FNowOptions := FNowOptions + [toZBuffer];
		4833	except
		4834	Finalize;
		4835	raise;
		4836	end;
		4837
		4838	FInitFlag := True; DoInitialize;
		4839	end;
		4840
		4841	procedure TCustomDX3D.Render;
		4842	begin
		4843	if FInitialized and (toRetainedMode in FNowOptions) then
		4844	begin
		4845	asm FInit end;
		4846	FViewport.Clear;
		4847	FViewport.Render(FScene);
		4848	FD3DRMDevice.Update;
		4849	asm FInit end;
		4850	end;
		4851	end;
		4852
		4853	function TCustomDX3D.GetCanDraw: Boolean;
		4854	begin
		4855	Result := Initialized and (Surface.IDDSurface<>nil) and
		4856	(Surface.ISurface.IsLost=DD_OK);
		4857	end;
		4858
		4859	function TCustomDX3D.GetSurfaceHeight: Integer;
		4860	begin
		4861	if FSurface.IDDSurface<>nil then
		4862	Result := FSurface.Height
		4863	else
		4864	Result := FSurfaceHeight;
		4865	end;
		4866
		4867	function TCustomDX3D.GetSurfaceWidth: Integer;
		4868	begin
		4869	if FSurface.IDDSurface<>nil then
		4870	Result := FSurface.Width
		4871	else
		4872	Result := FSurfaceWidth;
		4873	end;
		4874
		4875	procedure TCustomDX3D.SetAutoSize(Value: Boolean);
		4876	begin
		4877	if FAutoSize<>Value then
		4878	begin
		4879	FAutoSize := Value;
		4880	if FAutoSize and (DXDraw<>nil) then
		4881	SetSize(DXDraw.SurfaceWidth, DXDraw.SurfaceHeight);
		4882	end;
		4883	end;
		4884
		4885	procedure TCustomDX3D.SetOptions(Value: TDX3DOptions);
		4886	const
		4887	DX3DOptions = [toRetainedMode, toSystemMemory, toHardware, toSelectDriver, toZBuffer];
		4888	InitOptions = [toSystemMemory, toHardware, toSelectDriver, toZBuffer];
		4889	var
		4890	OldOptions: TDX3DOptions;
		4891	begin
		4892	FOptions := Value;
		4893
		4894	if Initialized then
		4895	begin
		4896	OldOptions := FNowOptions;
		4897	FNowOptions := FNowOptionsInitOptions+FOptions(DX3DOptions - InitOptions);
		4898	end else
		4899	begin
		4900	FNowOptions := FOptions;
		4901
		4902	if (FDXDraw<>nil) and (doDirectX7Mode in FDXDraw.FNowOptions) then
		4903	FNowOptions := FNowOptions - [toRetainedMode];
		4904	end;
		4905	end;
		4906
		4907	procedure TCustomDX3D.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
		4908	begin
		4909	if (ASurfaceWidth<>SurfaceWidth) or (ASurfaceHeight<>SurfaceHeight) then
		4910	begin
		4911	FSurfaceWidth := ASurfaceWidth;
		4912	FSurfaceHeight := ASurfaceHeight;
		4913
		4914	if Initialized then
		4915	Initialize;
		4916	end;
		4917	end;
		4918
		4919	procedure TCustomDX3D.SetSurfaceHeight(Value: Integer);
		4920	begin
		4921	if ComponentState*[csReading, csLoading]=[] then
		4922	SetSize(SurfaceWidth, Value)
		4923	else
		4924	FSurfaceHeight := Value;
		4925	end;
		4926
		4927	procedure TCustomDX3D.SetSurfaceWidth(Value: Integer);
		4928	begin
		4929	if ComponentState*[csReading, csLoading]=[] then
		4930	SetSize(Value, SurfaceHeight)
		4931	else
		4932	FSurfaceWidth := Value;
		4933	end;
		4934
		4935	procedure TCustomDX3D.Notification(AComponent: TComponent;
		4936	Operation: TOperation);
		4937	begin
		4938	inherited Notification(AComponent, Operation);
		4939	if (Operation=opRemove) and (FDXDraw=AComponent) then
		4940	DXDraw := nil;
		4941	end;
		4942
		4943	procedure TCustomDX3D.DXDrawNotifyEvent(Sender: TCustomDXDraw;
		4944	NotifyType: TDXDrawNotifyType);
		4945	var
		4946	AOptions: TInitializeDirect3DOptions;
		4947	begin
		4948	case NotifyType of
		4949	dxntDestroying:
		4950	begin
		4951	DXDraw := nil;
		4952	end;
		4953	dxntInitializing:
		4954	begin
		4955	if (FDXDraw.FOptions*[do3D, doFullScreen]=[doFullScreen])
		4956	and (FOptions*[toSystemMemory, toSelectDriver]=[toSelectDriver]) then
		4957	begin
		4958	AOptions := [];
		4959	with FDXDraw do
		4960	begin
		4961	if doHardware in Options then AOptions := AOptions + [idoHardware];
		4962	if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
		4963	if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
		4964	if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
		4965	end;
		4966
		4967	Direct3DInitializing_DXDraw(AOptions, FDXDraw);
		4968	end;
		4969	end;
		4970	dxntInitialize:
		4971	begin
		4972	Initialize;
		4973	end;
		4974	dxntFinalize:
		4975	begin
		4976	Finalize;
		4977	end;
		4978	dxntRestore:
		4979	begin
		4980	FSurface.Restore;
		4981	if FZBuffer<>nil then
		4982	FZBuffer.Restore;
		4983	FSurface.Palette := FDXDraw.Palette;
		4984	end;
		4985	dxntSetSurfaceSize:
		4986	begin
		4987	if AutoSize then
		4988	SetSize(Sender.SurfaceWidth, Sender.SurfaceHeight);
		4989	end;
		4990	end;
		4991	end;
		4992
		4993	procedure TCustomDX3D.SetDXDraw(Value: TCustomDXDraw);
		4994	begin
		4995	if FDXDraw<>Value then
		4996	begin
		4997	if FDXDraw<>nil then
		4998	FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
		4999
		5000	FDXDraw := Value;
		5001
		5002	if FDXDraw<>nil then
		5003	FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
		5004	end;
		5005	end;
		5006
		5007	{ TDirect3DTexture }
		5008
		5009	constructor TDirect3DTexture.Create(Graphic: TGraphic; DXDraw: TComponent);
		5010	var
		5011	i: Integer;
		5012	begin
		5013	inherited Create;
		5014	FDXDraw := DXDraw;
		5015	FGraphic := Graphic;
		5016
		5017	{ The palette is acquired. }
		5018	i := GetPaletteEntries(FGraphic.Palette, 0, 256, FPaletteEntries);
		5019	case i of
		5020	1..2 : FBitCount := 1;
		5021	3..16 : FBitCount := 4;
		5022	17..256: FBitCount := 8;
		5023	else
		5024	FBitCount := 24;
		5025	end;
		5026
		5027	if FDXDraw is TCustomDXDraw then
		5028	begin
		5029	with (FDXDraw as TCustomDXDraw) do
		5030	begin
		5031	if (not Initialized) or (not (do3D in NowOptions)) then
		5032	raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
		5033	end;
		5034	FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDXDraw).Surface.DDraw);
		5035	(FDXDraw as TCustomDXDraw).RegisterNotifyEvent(DXDrawNotifyEvent);
		5036	end else if FDXDraw is TCustomDX3D then
		5037	begin
		5038	with (FDXDraw as TDX3D) do
		5039	begin
		5040	if not Initialized then
		5041	raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
		5042	end;
		5043
		5044	FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDX3D).Surface.DDraw);
		5045	(FDXDraw as TCustomDX3D).FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
		5046	end else
		5047	raise EDirect3DTextureError.CreateFmt(SNotSupported, [FDXDraw.ClassName]);
		5048	end;
		5049
		5050	destructor TDirect3DTexture.Destroy;
		5051	begin
		5052	if FDXDraw is TCustomDXDraw then
		5053	begin
		5054	(FDXDraw as TCustomDXDraw).UnRegisterNotifyEvent(DXDrawNotifyEvent);
		5055	end else if FDXDraw is TCustomDX3D then
		5056	begin
		5057	(FDXDraw as TCustomDX3D).FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
		5058	end;
		5059
		5060	Clear;
		5061	FSurface.Free;
		5062	inherited Destroy;
		5063	end;
		5064
		5065	procedure TDirect3DTexture.Clear;
		5066	begin
		5067	FHandle := 0;
		5068	FTexture := nil;
		5069	FSurface.IDDSurface := nil;
		5070	end;
		5071
		5072	function TDirect3DTexture.GetHandle: TD3DTextureHandle;
		5073	begin
		5074	if FTexture=nil then
		5075	Restore;
		5076	Result := FHandle;
		5077	end;
		5078
		5079	function TDirect3DTexture.GetSurface: TDirectDrawSurface;
		5080	begin
		5081	if FTexture=nil then
		5082	Restore;
		5083	Result := FSurface;
		5084	end;
		5085
		5086	function TDirect3DTexture.GetTexture: IDirect3DTexture;
		5087	begin
		5088	if FTexture=nil then
		5089	Restore;
		5090	Result := FTexture;
		5091	end;
		5092
		5093	procedure TDirect3DTexture.SetTransparentColor(Value: TColor);
		5094	begin
		5095	if FTransparentColor<>Value then
		5096	begin
		5097	FTransparentColor := Value;
		5098
		5099	if FSurface<>nil then
		5100	FSurface.TransparentColor := FSurface.ColorMatch(Value);
		5101	end;
		5102	end;
		5103
		5104	procedure TDirect3DTexture.Restore;
		5105
		5106	function EnumTextureFormatCallback(const ddsd: TDDSurfaceDesc;
		5107	lParam: Pointer): HRESULT; stdcall;
		5108	var
		5109	tex: TDirect3DTexture;
		5110
		5111	procedure UseThisFormat;
		5112	begin
		5113	tex.FFormat := ddsd;
		5114	tex.FEnumFormatFlag := True;
		5115	end;
		5116
		5117	begin
		5118	Result := DDENUMRET_OK;
		5119	tex := lParam;
		5120
		5121	if ddsd.ddpfPixelFormat.dwFlags and (DDPF_ALPHA or DDPF_ALPHAPIXELS)<>0 then
		5122	Exit;
		5123
		5124	if not tex.FEnumFormatFlag then
		5125	begin
		5126	{ When called first, this format is unconditionally selected. }
		5127	UseThisFormat;
		5128	end else
		5129	begin
		5130	if (tex.FBitCount<=8) and (ddsd.ddpfPixelFormat.dwRGBBitCount>=tex.FBitCount) and
		5131	(ddsd.ddpfPixelFormat.dwRGBBitCount>=8) and
		5132	(ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB<>0) then
		5133	begin
		5134	if tex.FFormat.ddpfPixelFormat.dwRGBBitCount>ddsd.ddpfPixelFormat.dwRGBBitCount then
		5135	UseThisFormat;
		5136	end else
		5137	begin
		5138	if (tex.FFormat.ddpfPixelFormat.dwRGBBitCount>ddsd.ddpfPixelFormat.dwRGBBitCount) and
		5139	(ddsd.ddpfPixelFormat.dwRGBBitCount>8) and
		5140	(ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB<>0) then
		5141	UseThisFormat;
		5142	end;
		5143	end;
		5144	end;
		5145
		5146	function GetBitCount(i: Integer): Integer;
		5147	var
		5148	j: Integer;
		5149	begin
		5150	for j:=32 downto 1 do
		5151	if (1 shl j) and i<>0 then
		5152	begin
		5153	Result := j;
		5154	if 1 shl j<>i then
		5155	Dec(Result);
		5156	Exit;
		5157	end;
		5158	Result := 0;
		5159	end;
		5160
		5161	function CreateHalftonePalette(R, G, B: Integer): TPaletteEntries;
		5162	var
		5163	i: Integer;
		5164	begin
		5165	for i:=0 to 255 do
		5166	with Result[i] do
		5167	begin
		5168	peRed := ((i shr (G+B-1)) and (1 shl R-1)) * 255 div (1 shl R-1);
		5169	peGreen := ((i shr (B-1)) and (1 shl G-1)) * 255 div (1 shl G-1);
		5170	peBlue := ((i shr 0) and (1 shl B-1)) * 255 div (1 shl B-1);
		5171	peFlags := 0;
		5172	end;
		5173	end;
		5174
		5175	var
		5176	ddsd: TDDSurfaceDesc;
		5177	Palette: TDirectDrawPalette;
		5178	PaletteCaps: Integer;
		5179	TempSurface: TDirectDrawSurface;
		5180	Width2, Height2: Integer;
		5181	D3DDevice: IDirect3DDevice;
		5182	Hardware: Boolean;
		5183	DDraw: TDirectDraw;
		5184	begin
		5185	Clear;
		5186	try
		5187	DDraw := nil;
		5188	Hardware := False;
		5189	if FDXDraw is TCustomDXDraw then
		5190	begin
		5191	DDraw := (FDXDraw as TCustomDXDraw).DDraw;
		5192	D3DDevice := (FDXDraw as TCustomDXDraw).D3DDevice;
		5193	Hardware := doHardware in (FDXDraw as TCustomDXDraw).NowOptions;
		5194	end else if FDXDraw is TCustomDX3D then
		5195	begin
		5196	DDraw := (FDXDraw as TCustomDX3D).Surface.DDraw;
		5197	D3DDevice := (FDXDraw as TCustomDX3D).D3DDevice;
		5198	Hardware := toHardware in (FDXDraw as TCustomDX3D).NowOptions;
		5199	end;
		5200
		5201	if (DDraw=nil) or (D3DDevice=nil) then Exit;
		5202
		5203	{ The size of texture is arranged in the size of the square of two. }
		5204	Width2 := Max(1 shl GetBitCount(FGraphic.Width), 1);
		5205	Height2 := Max(1 shl GetBitCount(FGraphic.Height), 1);
		5206
		5207	{ Selection of format of texture. }
		5208	FEnumFormatFlag := False;
		5209	D3DDevice.EnumTextureFormats(@EnumTextureFormatCallback, Self);
		5210
		5211	TempSurface := TDirectDrawSurface.Create(FSurface.DDraw);
		5212	try
		5213	{ Make source surface. }
		5214	with ddsd do
		5215	begin
		5216	dwSize := SizeOf(ddsd);
		5217	dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
		5218	ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
		5219	dwWidth := Width2;
		5220	dwHeight := Height2;
		5221	ddpfPixelFormat := FFormat.ddpfPixelFormat;
		5222	end;
		5223
		5224	if not TempSurface.CreateSurface(ddsd) then
		5225	raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
		5226
		5227	{ Make surface. }
		5228	with ddsd do
		5229	begin
		5230	dwSize := SizeOf(ddsd);
		5231	dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
		5232	if Hardware then
		5233	ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_VIDEOMEMORY
		5234	else
		5235	ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
		5236	ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_ALLOCONLOAD;
		5237	dwWidth := Width2;
		5238	dwHeight := Height2;
		5239	ddpfPixelFormat := FFormat.ddpfPixelFormat;
		5240	end;
		5241
		5242	if not FSurface.CreateSurface(ddsd) then
		5243	raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
		5244
		5245	{ Make palette. }
		5246	if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8<>0 then
		5247	begin
		5248	PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256;
		5249	if FBitCount=24 then
		5250	CreateHalftonePalette(3, 3, 2);
		5251	end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4<>0 then
		5252	begin
		5253	PaletteCaps := DDPCAPS_4BIT;
		5254	if FBitCount=24 then
		5255	CreateHalftonePalette(1, 2, 1);
		5256	end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1<>0 then
		5257	begin
		5258	PaletteCaps := DDPCAPS_1BIT;
		5259	if FBitCount=24 then
		5260	begin
		5261	FPaletteEntries[0] := RGBQuadToPaletteEntry(RGBQuad(0, 0, 0));
		5262	FPaletteEntries[1] := RGBQuadToPaletteEntry(RGBQuad(255, 255, 255));
		5263	end;
		5264	end else
		5265	PaletteCaps := 0;
		5266
		5267	if PaletteCaps<>0 then
		5268	begin
		5269	Palette := TDirectDrawPalette.Create(DDraw);
		5270	try
		5271	Palette.CreatePalette(PaletteCaps, FPaletteEntries);
		5272	TempSurface.Palette := Palette;
		5273	FSurface.Palette := Palette;
		5274	finally
		5275	Palette.Free;
		5276	end;
		5277	end;
		5278
		5279	{ The image is loaded into source surface. }
		5280	with TempSurface.Canvas do
		5281	begin
		5282	StretchDraw(TempSurface.ClientRect, FGraphic);
		5283	Release;
		5284	end;
		5285
		5286	{ Source surface is loaded into surface. }
		5287	FTexture := FSurface.ISurface as IDirect3DTexture;
		5288	FTexture.Load(TempSurface.ISurface as IDirect3DTexture);
		5289	finally
		5290	TempSurface.Free;
		5291	end;
		5292
		5293	if FTexture.GetHandle(D3DDevice, FHandle)<>D3D_OK then
		5294	raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
		5295
		5296	FSurface.TransparentColor := FSurface.ColorMatch(FTransparentColor);
		5297	except
		5298	Clear;
		5299	raise;
		5300	end;
		5301	end;
		5302
		5303	procedure TDirect3DTexture.DXDrawNotifyEvent(Sender: TCustomDXDraw;
		5304	NotifyType: TDXDrawNotifyType);
		5305	begin
		5306	case NotifyType of
		5307	dxntInitializeSurface:
		5308	begin
		5309	Restore;
		5310	end;
		5311	dxntRestore:
		5312	begin
		5313	Restore;
		5314	end;
		5315	end;
		5316	end;
		5317
		5318	{ TDirect3DTexture2 }
		5319
		5320	constructor TDirect3DTexture2.Create(ADXDraw: TCustomDXDraw; Graphic: TObject;
		5321	AutoFreeGraphic: Boolean);
		5322	begin
		5323	inherited Create;
		5324	FSrcImage := Graphic;
		5325	FAutoFreeGraphic := AutoFreeGraphic;
		5326	FNeedLoadTexture := True;
		5327
		5328	if FSrcImage is TDXTextureImage then
		5329	FImage := TDXTextureImage(FSrcImage)
		5330	else if FSrcImage is TDIB then
		5331	SetDIB(TDIB(FSrcImage))
		5332	else if FSrcImage is TGraphic then
		5333	begin
		5334	FSrcImage := TDIB.Create;
		5335	try
		5336	TDIB(FSrcImage).Assign(TGraphic(Graphic));
		5337	SetDIB(TDIB(FSrcImage));
		5338	finally
		5339	if FAutoFreeGraphic then
		5340	Graphic.Free;
		5341	FAutoFreeGraphic := True;
		5342	end;
		5343	end else
		5344	if FSrcImage is TPicture then
		5345	begin
		5346	FSrcImage := TDIB.Create;
		5347	try
		5348	TDIB(FSrcImage).Assign(TPicture(Graphic).Graphic);
		5349	SetDIB(TDIB(FSrcImage));
		5350	finally
		5351	if FAutoFreeGraphic then
		5352	Graphic.Free;
		5353	FAutoFreeGraphic := True;
		5354	end;
		5355	end else
		5356	raise Exception.CreateFmt(SCannotLoadGraphic, [Graphic.ClassName]);
		5357
		5358	FMipmap := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap]>0;
		5359
		5360	FTransparent := FImage.Transparent;
		5361	case FImage.ImageType of
		5362	DXTextureImageType_PaletteIndexedColor:
		5363	begin
		5364	FTransparentColor := PaletteIndex(dxtDecodeChannel(FImage.idx_index, FImage.TransparentColor));
		5365	end;
		5366	DXTextureImageType_RGBColor:
		5367	begin
		5368	FTransparentColor := RGB(dxtDecodeChannel(FImage.rgb_red, FImage.TransparentColor),
		5369	dxtDecodeChannel(FImage.rgb_green, FImage.TransparentColor),
		5370	dxtDecodeChannel(FImage.rgb_blue, FImage.TransparentColor));
		5371	end;
		5372	end;
		5373
		5374	SetDXDraw(ADXDraw);
		5375	end;
		5376
		5377	constructor TDirect3DTexture2.CreateFromFile(ADXDraw: TCustomDXDraw; const FileName: string);
		5378	var
		5379	Image: TObject;
		5380	begin
		5381	Image := nil;
		5382	try
		5383	{ TDXTextureImage }
		5384	Image := TDXTextureImage.Create;
		5385	try
		5386	TDXTextureImage(Image).LoadFromFile(FileName);
		5387	except
		5388	Image.Free;
		5389	Image := nil;
		5390	end;
		5391
		5392	{ TDIB }
		5393	if Image=nil then
		5394	begin
		5395	Image := TDIB.Create;
		5396	try
		5397	TDIB(Image).LoadFromFile(FileName);
		5398	except
		5399	Image.Free;
		5400	Image := nil;
		5401	end;
		5402	end;
		5403
		5404	{ TPicture }
		5405	if Image=nil then
		5406	begin
		5407	Image := TPicture.Create;
		5408	try
		5409	TPicture(Image).LoadFromFile(FileName);
		5410	except
		5411	Image.Free;
		5412	Image := nil;
		5413	raise;
		5414	end;
		5415	end;
		5416	except
		5417	Image.Free;
		5418	raise;
		5419	end;
		5420
		5421	Create(ADXDraw, Image, True);
		5422	end;
		5423
		5424	constructor TDirect3DTexture2.CreateVideoTexture(ADXDraw: TCustomDXDraw);
		5425	begin
		5426	inherited Create;
		5427	SetDXDraw(ADXDraw);
		5428	end;
		5429
		5430	destructor TDirect3DTexture2.Destroy;
		5431	begin
		5432	Finalize;
		5433
		5434	SetDXDraw(nil);
		5435
		5436	if FAutoFreeGraphic then
		5437	FSrcImage.Free;
		5438	FImage2.Free;
		5439	inherited Destroy;
		5440	end;
		5441
		5442	procedure TDirect3DTexture2.DXDrawNotifyEvent(Sender: TCustomDXDraw;
		5443	NotifyType: TDXDrawNotifyType);
		5444	begin
		5445	case NotifyType of
		5446	dxntDestroying:
		5447	begin
		5448	SetDXDraw(nil);
		5449	end;
		5450	dxntInitializeSurface:
		5451	begin
		5452	Initialize;
		5453	end;
		5454	dxntFinalizeSurface:
		5455	begin
		5456	Finalize;
		5457	end;
		5458	dxntRestore:
		5459	begin
		5460	Load;
		5461	end;
		5462	end;
		5463	end;
		5464
		5465	procedure TDirect3DTexture2.SetDXDraw(ADXDraw: TCustomDXDraw);
		5466	begin
		5467	if FDXDraw<>ADXDraw then
		5468	begin
		5469	if FDXDraw<>nil then
		5470	FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
		5471
		5472	FDXDraw := ADXDraw;
		5473
		5474	if FDXDraw<>nil then
		5475	FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
		5476	end;
		5477	end;
		5478
		5479	procedure TDirect3DTexture2.DoRestoreSurface;
		5480	begin
		5481	if Assigned(FOnRestoreSurface) then
		5482	FOnRestoreSurface(Self);
		5483	end;
		5484
		5485	procedure TDirect3DTexture2.SetDIB(DIB: TDIB);
		5486	var
		5487	i: Integer;
		5488	begin
		5489	if FImage2=nil then
		5490	FImage2 := TDXTextureImage.Create;
		5491
		5492	if DIB.BitCount<=8 then
		5493	begin
		5494	FImage2.SetImage(DXTextureImageType_PaletteIndexedColor, DIB.Width, DIB.Height, DIB.BitCount,
		5495	DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
		5496
		5497	FImage2.idx_index := dxtMakeChannel((1 shl DIB.BitCount)-1, True);
		5498	for i:=0 to 255 do
		5499	FImage2.idx_palette[i] := RGBQuadToPaletteEntry(DIB.ColorTable[i]);
		5500	end else
		5501	begin
		5502	FImage2.SetImage(DXTextureImageType_RGBColor, DIB.Width, DIB.Height, DIB.BitCount,
		5503	DIB.WidthBytes, DIB.NextLine, DIB.PBits, DIB.TopPBits, DIB.Size, False);
		5504
		5505	FImage2.rgb_red := dxtMakeChannel(DIB.NowPixelFormat.RBitMask, False);
		5506	FImage2.rgb_green := dxtMakeChannel(DIB.NowPixelFormat.GBitMask, False);
		5507	FImage2.rgb_blue := dxtMakeChannel(DIB.NowPixelFormat.BBitMask, False);
		5508
		5509	i := DIB.NowPixelFormat.RBitCount+DIB.NowPixelFormat.GBitCount+DIB.NowPixelFormat.BBitCount;
		5510	if i<DIB.BitCount then
		5511	FImage2.rgb_alpha := dxtMakeChannel(((1 shl (DIB.BitCount-i))-1) shl i, False);
		5512	end;
		5513
		5514	FImage := FImage2;
		5515	end;
		5516
		5517	function TDirect3DTexture2.GetIsMipmap: Boolean;
		5518	begin
		5519	if FSurface<>nil then
		5520	Result := FUseMipmap
		5521	else
		5522	Result := FMipmap;
		5523	end;
		5524
		5525	function TDirect3DTexture2.GetSurface: TDirectDrawSurface;
		5526	begin
		5527	Result := FSurface;
		5528	if (Result<>nil) and FNeedLoadTexture then
		5529	Load;
		5530	end;
		5531
		5532	function TDirect3DTexture2.GetTransparent: Boolean;
		5533	begin
		5534	if FSurface<>nil then
		5535	Result := FUseColorKey
		5536	else
		5537	Result := FTransparent;
		5538	end;
		5539
		5540	procedure TDirect3DTexture2.SetTransparent(Value: Boolean);
		5541	begin
		5542	if FTransparent<>Value then
		5543	begin
		5544	FTransparent := Value;
		5545	if FSurface<>nil then
		5546	SetColorKey;
		5547	end;
		5548	end;
		5549
		5550	procedure TDirect3DTexture2.SetTransparentColor(Value: TColorRef);
		5551	begin
		5552	if FTransparentColor<>Value then
		5553	begin
		5554	FTransparentColor := Value;
		5555	if (FSurface<>nil) and FTransparent then
		5556	SetColorKey;
		5557	end;
		5558	end;
		5559
		5560	procedure TDirect3DTexture2.Finalize;
		5561	begin
		5562	FSurface.Free; FSurface := nil;
		5563
		5564	FUseColorKey := False;
		5565	FUseMipmap := False;
		5566	FNeedLoadTexture := False;
		5567	end;
		5568
		5569	const
		5570	DDPF_PALETTEINDEXED = DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
		5571	DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8;
		5572
		5573	procedure TDirect3DTexture2.Initialize;
		5574
		5575	function GetBitCount(i: Integer): Integer;
		5576	begin
		5577	Result := 31;
		5578	while (i>=0) and (((1 shl Result) and i)=0) do Dec(Result);
		5579	end;
		5580
		5581	function GetMaskBitCount(b: Integer): Integer;
		5582	var
		5583	i: Integer;
		5584	begin
		5585	i := 0;
		5586	while (i<31) and (((1 shl i) and b)=0) do Inc(i);
		5587
		5588	Result := 0;
		5589	while ((1 shl i) and b)<>0 do
		5590	begin
		5591	Inc(i);
		5592	Inc(Result);
		5593	end;
		5594	end;
		5595
		5596	function GetPaletteBitCount(const ddpfPixelFormat: TDDPixelFormat): Integer;
		5597	begin
		5598	if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8<>0 then
		5599	Result := 8
		5600	else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4<>0 then
		5601	Result := 4
		5602	else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2<>0 then
		5603	Result := 2
		5604	else if ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1<>0 then
		5605	Result := 1
		5606	else
		5607	Result := 0;
		5608	end;
		5609
		5610	function EnumTextureFormatCallback(const lpDDPixFmt: TDDPixelFormat;
		5611	lParam: Pointer): HRESULT; stdcall;
		5612	var
		5613	tex: TDirect3DTexture2;
		5614
		5615	procedure UseThisFormat;
		5616	begin
		5617	tex.FTextureFormat.ddpfPixelFormat := lpDDPixFmt;
		5618	tex.FEnumTextureFormatFlag := True;
		5619	end;
		5620
		5621	var
		5622	rgb_red, rgb_green, rgb_blue, rgb_alpha, idx_index: Integer;
		5623	sum1, sum2: Integer;
		5624	begin
		5625	Result := DDENUMRET_OK;
		5626	tex := lParam;
		5627
		5628	{ Form acquisition of source image }
		5629	rgb_red := 0;
		5630	rgb_green := 0;
		5631	rgb_blue := 0;
		5632	rgb_alpha := 0;
		5633	idx_index := 0;
		5634
		5635	case tex.FImage.ImageType of
		5636	DXTextureImageType_RGBColor:
		5637	begin
		5638	{ RGB Color }
		5639	rgb_red := tex.FImage.rgb_red.bitcount;
		5640	rgb_green := tex.FImage.rgb_green.bitcount;
		5641	rgb_blue := tex.FImage.rgb_blue.bitcount;
		5642	rgb_alpha := tex.FImage.rgb_alpha.bitcount;
		5643	idx_index := 8;
		5644	end;
		5645	DXTextureImageType_PaletteIndexedColor:
		5646	begin
		5647	{ Index Color }
		5648	rgb_red := 8;
		5649	rgb_green := 8;
		5650	rgb_blue := 8;
		5651	rgb_alpha := tex.FImage.idx_alpha.bitcount;
		5652	idx_index := tex.FImage.idx_index.bitcount;
		5653	end;
		5654	end;
		5655
		5656	{ The texture examines whether this pixel format can be used. }
		5657	if lpDDPixFmt.dwFlags and DDPF_RGB=0 then Exit;
		5658
		5659	case tex.FImage.ImageType of
		5660	DXTextureImageType_RGBColor:
		5661	begin
		5662	if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED<>0 then Exit;
		5663	end;
		5664	DXTextureImageType_PaletteIndexedColor:
		5665	begin
		5666	if (lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED<>0) and
		5667	(GetPaletteBitCount(lpDDPixFmt)<idx_index) then Exit;
		5668	end;
		5669	end;
		5670
		5671	{ The pixel format which can be used is selected carefully. }
		5672	if tex.FEnumTextureFormatFlag then
		5673	begin
		5674	if lpDDPixFmt.dwFlags and DDPF_PALETTEINDEXED<>0 then
		5675	begin
		5676	{ Bit count check }
		5677	if Abs(Integer(lpDDPixFmt.dwRGBBitCount)-idx_index)>
		5678	Abs(Integer(tex.FTextureFormat.ddpfPixelFormat.dwRGBBitCount)-idx_index) then Exit;
		5679
		5680	{ Alpha channel check }
		5681	if rgb_alpha>0 then Exit;
		5682	end else
		5683	if lpDDPixFmt.dwFlags and DDPF_RGB<>0 then
		5684	begin
		5685	{ The alpha channel is indispensable. }
		5686	if (rgb_alpha>0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS=0) and
		5687	(lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS<>0) then
		5688	begin
		5689	UseThisFormat;
		5690	Exit;
		5691	end;
		5692
		5693	{ Alpha channel check }
		5694	if (rgb_alpha>0) and (tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_ALPHAPIXELS<>0) and
		5695	(lpDDPixFmt.dwFlags and DDPF_ALPHAPIXELS=0) then
		5696	begin
		5697	Exit;
		5698	end;
		5699
		5700	{ Bit count check }
		5701	if tex.FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED=0 then
		5702	begin
		5703	sum1 := Sqr(GetMaskBitCount(lpDDPixFmt.dwRBitMask)-rgb_red)+
		5704	Sqr(GetMaskBitCount(lpDDPixFmt.dwGBitMask)-rgb_green)+
		5705	Sqr(GetMaskBitCount(lpDDPixFmt.dwBBitMask)-rgb_blue)+
		5706	Sqr(GetMaskBitCount(lpDDPixFmt.dwRGBAlphaBitMask)-rgb_alpha);
		5707
		5708	sum2 := Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRBitMask)-rgb_red)+
		5709	Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwGBitMask)-rgb_green)+
		5710	Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwBBitMask)-rgb_blue)+
		5711	Sqr(GetMaskBitCount(tex.FTextureFormat.ddpfPixelFormat.dwRGBAlphaBitMask)-rgb_alpha);
		5712
		5713	if sum1>sum2 then Exit;
		5714	end;
		5715	end;
		5716	end;
		5717
		5718	UseThisFormat;
		5719	end;
		5720
		5721	var
		5722	Width, Height: Integer;
		5723	PaletteCaps: DWORD;
		5724	Palette: IDirectDrawPalette;
		5725	TempD3DDevDesc: TD3DDeviceDesc;
		5726	D3DDevDesc7: TD3DDeviceDesc7;
		5727	TempSurface: IDirectDrawSurface4;
		5728	begin
		5729	Finalize;
		5730	try
		5731	if FDXDraw.D3DDevice7<>nil then
		5732	begin
		5733	FDXDraw.D3DDevice7.GetCaps(D3DDevDesc7);
		5734	FD3DDevDesc.dpcLineCaps.dwTextureCaps := D3DDevDesc7.dpcLineCaps.dwTextureCaps;
		5735	FD3DDevDesc.dpcTriCaps.dwTextureCaps := D3DDevDesc7.dpcTriCaps.dwTextureCaps;
		5736	FD3DDevDesc.dwMinTextureWidth := D3DDevDesc7.dwMinTextureWidth;
		5737	FD3DDevDesc.dwMaxTextureWidth := D3DDevDesc7.dwMaxTextureWidth;
		5738	end else
		5739	begin
		5740	FD3DDevDesc.dwSize := SizeOf(FD3DDevDesc);
		5741	TempD3DDevDesc.dwSize := SizeOf(TempD3DDevDesc);
		5742	FDXDraw.D3DDevice3.GetCaps(FD3DDevDesc, TempD3DDevDesc);
		5743	end;
		5744
		5745	if FImage<>nil then
		5746	begin
		5747	{ Size adjustment of texture }
		5748	if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_POW2<>0 then
		5749	begin
		5750	{ The size of the texture is only Sqr(n). }
		5751	Width := Max(1 shl GetBitCount(FImage.Width), 1);
		5752	Height := Max(1 shl GetBitCount(FImage.Height), 1);
		5753	end else
		5754	begin
		5755	Width := FImage.Width;
		5756	Height := FImage.Height;
		5757	end;
		5758
		5759	if FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_SQUAREONLY<>0 then
		5760	begin
		5761	{ The size of the texture is only a square. }
		5762	if Width<Height then Width := Height;
		5763	Height := Width;
		5764	end;
		5765
		5766	if FD3DDevDesc.dwMinTextureWidth>0 then
		5767	Width := Max(Width, FD3DDevDesc.dwMinTextureWidth);
		5768
		5769	if FD3DDevDesc.dwMaxTextureWidth>0 then
		5770	Width := Min(Width, FD3DDevDesc.dwMaxTextureWidth);
		5771
		5772	if FD3DDevDesc.dwMinTextureHeight>0 then
		5773	Height := Max(Height, FD3DDevDesc.dwMinTextureHeight);
		5774
		5775	if FD3DDevDesc.dwMaxTextureHeight>0 then
		5776	Height := Min(Height, FD3DDevDesc.dwMaxTextureHeight);
		5777
		5778	{ Pixel format selection }
		5779	FEnumTextureFormatFlag := False;
		5780	if FDXDraw.D3DDevice7<>nil then
		5781	FDXDraw.D3DDevice7.EnumTextureFormats(@EnumTextureFormatCallback, Self)
		5782	else
		5783	FDXDraw.D3DDevice3.EnumTextureFormats(@EnumTextureFormatCallback, Self);
		5784
		5785	if not FEnumTextureFormatFlag then
		5786	raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
		5787
		5788	{ Is Mipmap surface used ? }
		5789	FUseMipmap := FMipmap and (FTextureFormat.ddpfPixelFormat.dwRGBBitCount>8) and
		5790	(FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap]>0) and (FDXDraw.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_MIPMAP<>0);
		5791
		5792	{ Surface form setting }
		5793	with FTextureFormat do
		5794	begin
		5795	dwSize := SizeOf(FTextureFormat);
		5796	dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
		5797	ddsCaps.dwCaps := DDSCAPS_TEXTURE;
		5798	ddsCaps.dwCaps2 := 0;
		5799	dwWidth := Width;
		5800	dwHeight := Height;
		5801
		5802	if doHardware in FDXDraw.NowOptions then
		5803	ddsCaps.dwCaps2 := ddsCaps.dwCaps2 or DDSCAPS2_TEXTUREMANAGE
		5804	else
		5805	ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
		5806
		5807	if FUseMipmap then
		5808	begin
		5809	dwFlags := dwFlags or DDSD_MIPMAPCOUNT;
		5810	ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
		5811	dwMipMapCount := FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap];
		5812	end;
		5813	end;
		5814	end;
		5815
		5816	FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
		5817	FSurface.DDraw.DXResult := FSurface.DDraw.IDraw4.CreateSurface(FTextureFormat, TempSurface, nil);
		5818	if FSurface.DDraw.DXResult<>DD_OK then
		5819	raise EDirect3DTextureError.CreateFmt(SCannotInitialized, [STexture]);
		5820	FSurface.IDDSurface4 := TempSurface;
		5821
		5822	{ Palette making }
		5823	if (FImage<>nil) and (FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED<>0) then
		5824	begin
		5825	if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8<>0 then
		5826	PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256
		5827	else if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4<>0 then
		5828	PaletteCaps := DDPCAPS_4BIT
		5829	else if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED2<>0 then
		5830	PaletteCaps := DDPCAPS_2BIT
		5831	else if FTextureFormat.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1<>0 then
		5832	PaletteCaps := DDPCAPS_1BIT
		5833	else
		5834	PaletteCaps := 0;
		5835
		5836	if PaletteCaps<>0 then
		5837	begin
		5838	if FDXDraw.DDraw.IDraw.CreatePalette(PaletteCaps, @FImage.idx_palette, Palette, nil)<>0 then
		5839	Exit;
		5840
		5841	FSurface.ISurface.SetPalette(Palette);
		5842	end;
		5843	end;
		5844
		5845	FNeedLoadTexture := True;
		5846	except
		5847	Finalize;
		5848	raise;
		5849	end;
		5850	end;
		5851
		5852	procedure TDirect3DTexture2.Load;
		5853	const
		5854	MipmapCaps: TDDSCaps2 = (dwCaps: DDSCAPS_TEXTURE or DDSCAPS_MIPMAP);
		5855	var
		5856	CurSurface, NextSurface: IDirectDrawSurface4;
		5857	Index: Integer;
		5858	SrcImage: TDXTextureImage;
		5859	begin
		5860	if FSurface=nil then
		5861	Initialize;
		5862
		5863	FNeedLoadTexture := False;
		5864	if FSurface.ISurface.IsLost=DDERR_SURFACELOST then
		5865	FSurface.Restore;
		5866
		5867	{ Color key setting. }
		5868	SetColorKey;
		5869
		5870	{ Image loading into surface. }
		5871	if FImage<>nil then
		5872	begin
		5873	if FSrcImage is TDIB then
		5874	SetDIB(TDIB(FSrcImage));
		5875
		5876	CurSurface := FSurface.ISurface4;
		5877	Index := 0;
		5878	while CurSurface<>nil do
		5879	begin
		5880	SrcImage := FImage;
		5881	if Index>0 then
		5882	begin
		5883	if Index-1>=FImage.SubGroupImageCount[DXTextureImageGroupType_Mipmap] then
		5884	Break;
		5885	SrcImage := FImage.SubGroupImages[DXTextureImageGroupType_Mipmap, Index-1];
		5886	end;
		5887
		5888	LoadSubTexture(CurSurface, SrcImage);
		5889
		5890	if CurSurface.GetAttachedSurface(MipmapCaps, NextSurface)=0 then
		5891	CurSurface := NextSurface
		5892	else
		5893	CurSurface := nil;
		5894
		5895	Inc(Index);
		5896	end;
		5897	end else
		5898	DoRestoreSurface;
		5899	end;
		5900
		5901	procedure TDirect3DTexture2.SetColorKey;
		5902	var
		5903	ck: TDDColorKey;
		5904	begin
		5905	FUseColorKey := False;
		5906
		5907	if (FSurface<>nil) and FTransparent and (FD3DDevDesc.dpcTriCaps.dwTextureCaps and D3DPTEXTURECAPS_TRANSPARENCY<>0) then
		5908	begin
		5909	FillChar(ck, SizeOf(ck), 0);
		5910	if FSurface.SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED<>0 then
		5911	begin
		5912	if FTransparentColor shr 24=$01 then
		5913	begin
		5914	{ Palette index }
		5915	ck.dwColorSpaceLowValue := FTransparentColor and $FF;
		5916	end else
		5917	if FImage<>nil then
		5918	begin
		5919	{ RGB value }
		5920	ck.dwColorSpaceLowValue := FImage.PaletteIndex(GetRValue(FTransparentColor), GetGValue(FTransparentColor), GetBValue(FTransparentColor));
		5921	end else
		5922	Exit;
		5923	end else
		5924	begin
		5925	if (FImage<>nil) and (FImage.ImageType=DXTextureImageType_PaletteIndexedColor) and (FTransparentColor shr 24=$01) then
		5926	begin
		5927	{ Palette index }
		5928	ck.dwColorSpaceLowValue :=
		5929	dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peRed) or
		5930	dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peGreen) or
		5931	dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), FImage.idx_palette[FTransparentColor and $FF].peBlue);
		5932	end else
		5933	if FTransparentColor shr 24=$00 then
		5934	begin
		5935	{ RGB value }
		5936	ck.dwColorSpaceLowValue :=
		5937	dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwRBitMask, False), GetRValue(FTransparentColor)) or
		5938	dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwGBitMask, False), GetGValue(FTransparentColor)) or
		5939	dxtEncodeChannel(dxtMakeChannel(FSurface.SurfaceDesc.ddpfPixelFormat.dwBBitMask, False), GetBValue(FTransparentColor));
		5940	end else
		5941	Exit;
		5942	end;
		5943
		5944	ck.dwColorSpaceHighValue := ck.dwColorSpaceLowValue;
		5945	FSurface.ISurface.SetColorKey(DDCKEY_SRCBLT, ck);
		5946
		5947	FUseColorKey := True;
		5948	end;
		5949	end;
		5950
		5951	procedure TDirect3DTexture2.LoadSubTexture(Dest: IDirectDrawSurface4; SrcImage: TDXTextureImage);
		5952	const
		5953	Mask1: array[0..7] of DWORD = (1, 2, 4, 8, 16, 32, 64, 128);
		5954	Mask2: array[0..3] of DWORD = (3, 12, 48, 192);
		5955	Mask4: array[0..1] of DWORD = ($0F, $F0);
		5956	Shift1: array[0..7] of DWORD = (0, 1, 2, 3, 4, 5, 6, 7);
		5957	Shift2: array[0..3] of DWORD = (0, 2, 4, 6);
		5958	Shift4: array[0..1] of DWORD = (0, 4);
		5959
		5960	procedure SetPixel(const ddsd: TDDSurfaceDesc2; x, y: Integer; c: DWORD);
		5961	begin
		5962	case ddsd.ddpfPixelFormat.dwRGBBitCount of
		5963	1 : PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x div 8)^ :=
		5964	(PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x div 8)^ and (not Mask1[x mod 8])) or (c shl Shift1[x mod 8]);
		5965	2 : PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x div 4)^ :=
		5966	(PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x div 4)^ and (not Mask2[x mod 4])) or (c shl Shift2[x mod 4]);
		5967	4 : PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x div 2)^ :=
		5968	(PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x div 2)^ and (not Mask4[x mod 2])) or (c shl Shift4[x mod 2]);
		5969	8 : PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x)^ := c;
		5970	16: PWord(Integer(ddsd.lpSurface)+ddsd.lPitchy+x2)^ := c;
		5971	24: begin
		5972	PByte(Integer(ddsd.lpSurface)+ddsd.lPitchy+x3)^ := c shr 0;
		5973	PByte(Integer(ddsd.lpSurface)+ddsd.lPitchy+x3+1)^ := c shr 8;
		5974	PByte(Integer(ddsd.lpSurface)+ddsd.lPitchy+x3+2)^ := c shr 16;
		5975	end;
		5976	32: PDWORD(Integer(ddsd.lpSurface)+ddsd.lPitchy+x4)^ := c;
		5977	end;
		5978	end;
		5979
		5980	procedure LoadTexture_IndexToIndex;
		5981	var
		5982	ddsd: TDDSurfaceDesc2;
		5983	x, y: Integer;
		5984	begin
		5985	ddsd.dwSize := SizeOf(ddsd);
		5986	if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0)=0 then
		5987	begin
		5988	try
		5989	if (SrcImage.idx_index.Mask=DWORD(1 shl ddsd.ddpfPixelFormat.dwRGBBitCount)-1) and (SrcImage.idx_alpha.Mask=0) and
		5990	(SrcImage.BitCount=Integer(ddsd.ddpfPixelFormat.dwRGBBitCount)) and (not SrcImage.PackedPixelOrder) then
		5991	begin
		5992	for y:=0 to ddsd.dwHeight-1 do
		5993	Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface)+ddsd.lPitchy)^, (Integer(ddsd.dwWidth)SrcImage.BitCount+7) div 8);
		5994	end else
		5995	begin
		5996	for y:=0 to ddsd.dwHeight-1 do
		5997	begin
		5998	for x:=0 to ddsd.dwWidth-1 do
		5999	SetPixel(ddsd, x, y, dxtDecodeChannel(SrcImage.idx_index, SrcImage.Pixels[x, y]));
		6000	end;
		6001	end;
		6002	finally
		6003	Dest.UnLock(ddsd.lpSurface);
		6004	end;
		6005	end;
		6006	end;
		6007
		6008	procedure LoadTexture_IndexToRGB;
		6009	var
		6010	ddsd: TDDSurfaceDesc2;
		6011	x, y: Integer;
		6012	c, cIdx, cA: DWORD;
		6013	dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
		6014	begin
		6015	ddsd.dwSize := SizeOf(ddsd);
		6016	if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0)=0 then
		6017	begin
		6018	try
		6019	dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
		6020	dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
		6021	dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
		6022	dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
		6023
		6024	if SrcImage.idx_alpha.mask<>0 then
		6025	begin
		6026	for y:=0 to ddsd.dwHeight-1 do
		6027	for x:=0 to ddsd.dwWidth-1 do
		6028	begin
		6029	c := SrcImage.Pixels[x, y];
		6030	cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
		6031
		6032	c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
		6033	dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
		6034	dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or
		6035	dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.idx_alpha, c));
		6036
		6037	SetPixel(ddsd, x, y, c);
		6038	end;
		6039	end else
		6040	begin
		6041	cA := dxtEncodeChannel(dest_alpha_fmt, 255);
		6042
		6043	for y:=0 to ddsd.dwHeight-1 do
		6044	for x:=0 to ddsd.dwWidth-1 do
		6045	begin
		6046	c := SrcImage.Pixels[x, y];
		6047	cIdx := dxtDecodeChannel(SrcImage.idx_index, c);
		6048
		6049	c := dxtEncodeChannel(dest_red_fmt, SrcImage.idx_palette[cIdx].peRed) or
		6050	dxtEncodeChannel(dest_green_fmt, SrcImage.idx_palette[cIdx].peGreen) or
		6051	dxtEncodeChannel(dest_blue_fmt, SrcImage.idx_palette[cIdx].peBlue) or cA;
		6052
		6053	SetPixel(ddsd, x, y, c);
		6054	end;
		6055	end;
		6056	finally
		6057	Dest.UnLock(ddsd.lpSurface);
		6058	end;
		6059	end;
		6060	end;
		6061
		6062	procedure LoadTexture_RGBToRGB;
		6063	var
		6064	ddsd: TDDSurfaceDesc2;
		6065	x, y: Integer;
		6066	c, cA: DWORD;
		6067	dest_red_fmt, dest_green_fmt, dest_blue_fmt, dest_alpha_fmt: TDXTextureImageChannel;
		6068	begin
		6069	ddsd.dwSize := SizeOf(ddsd);
		6070	if Dest.Lock(nil, ddsd, DDLOCK_WAIT, 0)=0 then
		6071	begin
		6072	try
		6073	dest_red_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRBitMask, False);
		6074	dest_green_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwGBitMask, False);
		6075	dest_blue_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwBBitMask, False);
		6076	dest_alpha_fmt := dxtMakeChannel(ddsd.ddpfPixelFormat.dwRGBAlphaBitMask, False);
		6077
		6078	if (dest_red_fmt.Mask=SrcImage.rgb_red.Mask) and (dest_green_fmt.Mask=SrcImage.rgb_green.Mask) and
		6079	(dest_blue_fmt.Mask=SrcImage.rgb_blue.Mask) and (dest_alpha_fmt.Mask=SrcImage.rgb_alpha.Mask) and
		6080	(Integer(ddsd.ddpfPixelFormat.dwRGBBitCount)=SrcImage.BitCount) and (not SrcImage.PackedPixelOrder) then
		6081	begin
		6082	for y:=0 to ddsd.dwHeight-1 do
		6083	Move(SrcImage.ScanLine[y]^, Pointer(Integer(ddsd.lpSurface)+ddsd.lPitchy)^, (Integer(ddsd.dwWidth)SrcImage.BitCount+7) div 8);
		6084	end else
		6085	if SrcImage.rgb_alpha.mask<>0 then
		6086	begin
		6087	for y:=0 to ddsd.dwHeight-1 do
		6088	for x:=0 to ddsd.dwWidth-1 do
		6089	begin
		6090	c := SrcImage.Pixels[x, y];
		6091
		6092	c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
		6093	dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
		6094	dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or
		6095	dxtEncodeChannel(dest_alpha_fmt, dxtDecodeChannel(SrcImage.rgb_alpha, c));
		6096
		6097	SetPixel(ddsd, x, y, c);
		6098	end;
		6099	end else
		6100	begin
		6101	cA := dxtEncodeChannel(dest_alpha_fmt, 255);
		6102
		6103	for y:=0 to ddsd.dwHeight-1 do
		6104	for x:=0 to ddsd.dwWidth-1 do
		6105	begin
		6106	c := SrcImage.Pixels[x, y];
		6107
		6108	c := dxtEncodeChannel(dest_red_fmt, dxtDecodeChannel(SrcImage.rgb_red, c)) or
		6109	dxtEncodeChannel(dest_green_fmt, dxtDecodeChannel(SrcImage.rgb_green, c)) or
		6110	dxtEncodeChannel(dest_blue_fmt, dxtDecodeChannel(SrcImage.rgb_blue, c)) or cA;
		6111
		6112	SetPixel(ddsd, x, y, c);
		6113	end;
		6114	end;
		6115	finally
		6116	Dest.UnLock(ddsd.lpSurface);
		6117	end;
		6118	end;
		6119	end;
		6120
		6121	var
		6122	SurfaceDesc: TDDSurfaceDesc2;
		6123	begin
		6124	SurfaceDesc.dwSize := SizeOf(SurfaceDesc);
		6125	Dest.GetSurfaceDesc(SurfaceDesc);
		6126
		6127	if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED<>0 then
		6128	begin
		6129	case SrcImage.ImageType of
		6130	DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToIndex;
		6131	DXTextureImageType_RGBColor : ;
		6132	end;
		6133	end else if SurfaceDesc.ddpfPixelFormat.dwFlags and DDPF_RGB<>0 then
		6134	begin
		6135	case SrcImage.ImageType of
		6136	DXTextureImageType_PaletteIndexedColor: LoadTexture_IndexToRGB;
		6137	DXTextureImageType_RGBColor : LoadTexture_RGBToRGB;
		6138	end;
		6139	end;
		6140	end;
		6141
		6142	{ TDirect3DRMUserVisual }
		6143
		6144	procedure TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK(lpD3DRMobj: IDirect3DRMObject;
		6145	lpArg: Pointer); CDECL;
		6146	begin
		6147	TDirect3DRMUserVisual(lpArg).Free;
		6148	end;
		6149
		6150	function TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK(lpD3DRMUV: IDirect3DRMUserVisual;
		6151	lpArg: Pointer; lpD3DRMUVreason: TD3DRMUserVisualReason;
		6152	lpD3DRMDev: IDirect3DRMDevice; lpD3DRMview: IDirect3DRMViewport): Integer; CDECL;
		6153	begin
		6154	Result := TDirect3DRMUserVisual(lpArg).DoRender(lpD3DRMUVreason, lpD3DRMDev, lpD3DRMview);
		6155	end;
		6156
		6157	constructor TDirect3DRMUserVisual.Create(D3DRM: IDirect3DRM);
		6158	begin
		6159	inherited Create;
		6160
		6161	if D3DRM.CreateUserVisual(@TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK,
		6162	Self, FUserVisual)<>D3DRM_OK then
		6163	raise EDirect3DRMUserVisualError.CreateFmt(SCannotMade, ['IDirect3DRMUserVisual']);
		6164
		6165	FUserVisual.AddDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
		6166	end;
		6167
		6168	destructor TDirect3DRMUserVisual.Destroy;
		6169	begin
		6170	if FUserVisual<>nil then
		6171	FUserVisual.DeleteDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
		6172	FUserVisual := nil;
		6173	inherited Destroy;
		6174	end;
		6175
		6176	function TDirect3DRMUserVisual.DoRender(Reason: TD3DRMUserVisualReason;
		6177	D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT;
		6178	begin
		6179	Result := 0;
		6180	end;
		6181
		6182	{ TPictureCollectionItem }
		6183
		6184	const
		6185	SurfaceDivWidth = 512;
		6186	SurfaceDivHeight = 512;
		6187
		6188	type
		6189	TPictureCollectionItemPattern = class(TCollectionItem)
		6190	private
		6191	FRect: TRect;
		6192	FSurface: TDirectDrawSurface;
		6193	end;
		6194
		6195	constructor TPictureCollectionItem.Create(Collection: TCollection);
		6196	begin
		6197	inherited Create(Collection);
		6198	FPicture := TPicture.Create;
		6199	FPatterns := TCollection.Create(TPictureCollectionItemPattern);
		6200	FSurfaceList := TList.Create;
		6201	FTransparent := True;
		6202	end;
		6203
		6204	destructor TPictureCollectionItem.Destroy;
		6205	begin
		6206	Finalize;
		6207	FPicture.Free;
		6208	FPatterns.Free;
		6209	FSurfaceList.Free;
		6210	inherited Destroy;
		6211	end;
		6212
		6213	procedure TPictureCollectionItem.Assign(Source: TPersistent);
		6214	var
		6215	PrevInitialized: Boolean;
		6216	begin
		6217	if Source is TPictureCollectionItem then
		6218	begin
		6219	PrevInitialized := Initialized;
		6220	Finalize;
		6221
		6222	FPatternHeight := TPictureCollectionItem(Source).FPatternHeight;
		6223	FPatternWidth := TPictureCollectionItem(Source).FPatternWidth;
		6224	FSkipHeight := TPictureCollectionItem(Source).FSkipHeight;
		6225	FSkipWidth := TPictureCollectionItem(Source).FSkipWidth;
		6226	FSystemMemory := TPictureCollectionItem(Source).FSystemMemory;
		6227	FTransparent := TPictureCollectionItem(Source).FTransparent;
		6228	FTransparentColor := TPictureCollectionItem(Source).FTransparentColor;
		6229
		6230	FPicture.Assign(TPictureCollectionItem(Source).FPicture);
		6231
		6232	if PrevInitialized then
		6233	Restore;
		6234	end else
		6235	inherited Assign(Source);
		6236	end;
		6237
		6238	procedure TPictureCollectionItem.ClearSurface;
		6239	var
		6240	i: Integer;
		6241	begin
		6242	FPatterns.Clear;
		6243	for i:=0 to FSurfaceList.Count-1 do
		6244	TDirectDrawSurface(FSurfaceList[i]).Free;
		6245	FSurfaceList.Clear;
		6246	end;
		6247
		6248	function TPictureCollectionItem.GetHeight: Integer;
		6249	begin
		6250	Result := FPatternHeight;
		6251	if (Result<=0) then
		6252	Result := FPicture.Height;
		6253	end;
		6254
		6255	function TPictureCollectionItem.GetPictureCollection: TPictureCollection;
		6256	begin
		6257	Result := Collection as TPictureCollection;
		6258	end;
		6259
		6260	function TPictureCollectionItem.GetPatternRect(Index: Integer): TRect;
		6261	begin
		6262	if (Index>=0) and (index<FPatterns.Count) then
		6263	Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FRect
		6264	else
		6265	Result := Rect(0, 0, 0, 0);
		6266	end;
		6267
		6268	function TPictureCollectionItem.GetPatternSurface(Index: Integer): TDirectDrawSurface;
		6269	begin
		6270	if (Index>=0) and (index<FPatterns.Count) then
		6271	Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FSurface
		6272	else
		6273	Result := nil;
		6274	end;
		6275
		6276	function TPictureCollectionItem.GetPatternCount: Integer;
		6277	var
		6278	XCount, YCount: Integer;
		6279	begin
		6280	if FSurfaceList.Count=0 then
		6281	begin
		6282	XCount := FPicture.Width div (PatternWidth+SkipWidth);
		6283	if FPicture.Width-XCount*(PatternWidth+SkipWidth)=PatternWidth then
		6284	Inc(XCount);
		6285
		6286	YCount := FPicture.Height div (PatternHeight+SkipHeight);
		6287	if FPicture.Height-YCount*(PatternHeight+SkipHeight)=PatternHeight then
		6288	Inc(YCount);
		6289
		6290	Result := XCount*YCount;
		6291	end else
		6292	Result := FPatterns.Count;
		6293	end;
		6294
		6295	function TPictureCollectionItem.GetWidth: Integer;
		6296	begin
		6297	Result := FPatternWidth;
		6298	if (Result<=0) then
		6299	Result := FPicture.Width;
		6300	end;
		6301
		6302	procedure TPictureCollectionItem.Draw(Dest: TDirectDrawSurface; X, Y,
		6303	PatternIndex: Integer);
		6304	begin
		6305	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6306	begin
		6307	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6308	Dest.Draw(X, Y, FRect, FSurface, Transparent);
		6309	end;
		6310	end;
		6311
		6312	procedure TPictureCollectionItem.StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
		6313	begin
		6314	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6315	begin
		6316	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6317	Dest.StretchDraw(DestRect, FRect, FSurface, Transparent);
		6318	end;
		6319	end;
		6320
		6321	procedure TPictureCollectionItem.DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
		6322	Alpha: Integer);
		6323	begin
		6324	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6325	begin
		6326	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6327	Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
		6328	end;
		6329	end;
		6330
		6331	procedure TPictureCollectionItem.DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
		6332	Alpha: Integer);
		6333	begin
		6334	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6335	begin
		6336	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6337	Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
		6338	end;
		6339	end;
		6340
		6341	procedure TPictureCollectionItem.DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
		6342	Alpha: Integer);
		6343	begin
		6344	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6345	begin
		6346	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6347	Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
		6348	end;
		6349	end;
		6350
		6351	procedure TPictureCollectionItem.DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6352	CenterX, CenterY: Double; Angle: Integer);
		6353	begin
		6354	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6355	begin
		6356	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6357	Dest.DrawRotate(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle);
		6358	end;
		6359	end;
		6360
		6361	procedure TPictureCollectionItem.DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6362	CenterX, CenterY: Double; Angle, Alpha: Integer);
		6363	begin
		6364	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6365	begin
		6366	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6367	Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
		6368	end;
		6369	end;
		6370
		6371	procedure TPictureCollectionItem.DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6372	CenterX, CenterY: Double; Angle, Alpha: Integer);
		6373	begin
		6374	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6375	begin
		6376	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6377	Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
		6378	end;
		6379	end;
		6380
		6381	procedure TPictureCollectionItem.DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6382	CenterX, CenterY: Double; Angle, Alpha: Integer);
		6383	begin
		6384	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6385	begin
		6386	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6387	Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
		6388	end;
		6389	end;
		6390
		6391	procedure TPictureCollectionItem.DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6392	amp, Len, ph: Integer);
		6393	begin
		6394	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6395	begin
		6396	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6397	Dest.DrawWaveX(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph);
		6398	end;
		6399	end;
		6400
		6401	procedure TPictureCollectionItem.DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6402	amp, Len, ph, Alpha: Integer);
		6403	begin
		6404	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6405	begin
		6406	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6407	Dest.DrawWaveXAdd(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
		6408	end;
		6409	end;
		6410
		6411	procedure TPictureCollectionItem.DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6412	amp, Len, ph, Alpha: Integer);
		6413	begin
		6414	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6415	begin
		6416	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6417	Dest.DrawWaveXAlpha(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
		6418	end;
		6419	end;
		6420
		6421	procedure TPictureCollectionItem.DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
		6422	amp, Len, ph, Alpha: Integer);
		6423	begin
		6424	if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
		6425	begin
		6426	with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
		6427	Dest.DrawWaveXSub(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
		6428	end;
		6429	end;
		6430
		6431	procedure TPictureCollectionItem.Finalize;
		6432	begin
		6433	if FInitialized then
		6434	begin
		6435	FInitialized := False;
		6436	ClearSurface;
		6437	end;
		6438	end;
		6439
		6440	procedure TPictureCollectionItem.Initialize;
		6441	begin
		6442	Finalize;
		6443	FInitialized := PictureCollection.Initialized;
		6444	end;
		6445
		6446	procedure TPictureCollectionItem.Restore;
		6447
		6448	function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
		6449	begin
		6450	Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
		6451	FSurfaceList.Add(Result);
		6452
		6453	Result.SystemMemory := FSystemMemory;
		6454	Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
		6455	Result.TransparentColor := Result.ColorMatch(FTransparentColor);
		6456	end;
		6457
		6458	var
		6459	x, y, x2, y2: Integer;
		6460	BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
		6461	Width2, Height2: Integer;
		6462	begin
		6463	if FPicture.Graphic=nil then Exit;
		6464
		6465	if not FInitialized then
		6466	begin
		6467	if PictureCollection.Initialized then
		6468	Initialize;
		6469	if not FInitialized then Exit;
		6470	end;
		6471
		6472	ClearSurface;
		6473
		6474	Width2 := Width+SkipWidth;
		6475	Height2 := Height+SkipHeight;
		6476
		6477	if (Width=FPicture.Width) and (Height=FPicture.Height) then
		6478	begin
		6479	{ There is no necessity of division because the number of patterns is one. }
		6480	with TPictureCollectionItemPattern.Create(FPatterns) do
		6481	begin
		6482	FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
		6483	FSurface := AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
		6484	end;
		6485	end else if FSystemMemory then
		6486	begin
		6487	{ Load to a system memory. }
		6488	AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
		6489
		6490	for y:=0 to (FPicture.Height+SkipHeight) div Height2-1 do
		6491	for x:=0 to (FPicture.Width+SkipWidth) div Width2-1 do
		6492	with TPictureCollectionItemPattern.Create(FPatterns) do
		6493	begin
		6494	FRect := Bounds(x * Width2, y * Height2, Width, Height);
		6495	FSurface := TDirectDrawSurface(FSurfaceList[0]);
		6496	end;
		6497	end else
		6498	begin
		6499	{ Load to a video memory with dividing the image. }
		6500	BlockWidth := Min(((SurfaceDivWidth+Width2-1) div Width2)*Width2,
		6501	(FPicture.Width+SkipWidth) div Width2*Width2);
		6502	BlockHeight := Min(((SurfaceDivHeight+Height2-1) div Height2)*Height2,
		6503	(FPicture.Height+SkipHeight) div Height2*Height2);
		6504
		6505	if (BlockWidth=0) or (BlockHeight=0) then Exit;
		6506
		6507	BlockXCount := (FPicture.Width+BlockWidth-1) div BlockWidth;
		6508	BlockYCount := (FPicture.Height+BlockHeight-1) div BlockHeight;
		6509
		6510	for y:=0 to BlockYCount-1 do
		6511	for x:=0 to BlockXCount-1 do
		6512	begin
		6513	x2 := Min(BlockWidth, Max(FPicture.Width-x*BlockWidth, 0));
		6514	if x2=0 then x2 := BlockWidth;
		6515
		6516	y2 := Min(BlockHeight, Max(FPicture.Height-y*BlockHeight, 0));
		6517	if y2=0 then y2 := BlockHeight;
		6518
		6519	AddSurface(Bounds(xBlockWidth, yBlockHeight, x2, y2));
		6520	end;
		6521
		6522	for y:=0 to (FPicture.Height+SkipHeight) div Height2-1 do
		6523	for x:=0 to (FPicture.Width+SkipWidth) div Width2-1 do
		6524	begin
		6525	x2 := x * Width2;
		6526	y2 := y * Height2;
		6527	with TPictureCollectionItemPattern.Create(FPatterns) do
		6528	begin
		6529	FRect := Bounds(x2-(x2 div BlockWidthBlockWidth), y2-(y2 div BlockHeightBlockHeight), Width, Height);
		6530	FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth)+((y2 div BlockHeight)*BlockXCount)]);
		6531	end;
		6532	end;
		6533	end;
		6534	end;
		6535
		6536	procedure TPictureCollectionItem.SetPicture(Value: TPicture);
		6537	begin
		6538	FPicture.Assign(Value);
		6539	end;
		6540
		6541	procedure TPictureCollectionItem.SetTransparentColor(Value: TColor);
		6542	var
		6543	i: Integer;
		6544	Surface: TDirectDrawSurface;
		6545	begin
		6546	if Value<>FTransparentColor then
		6547	begin
		6548	FTransparentColor := Value;
		6549	for i:=0 to FSurfaceList.Count-1 do
		6550	begin
		6551	try
		6552	Surface := TDirectDrawSurface(FSurfaceList[i]);
		6553	Surface.TransparentColor := Surface.ColorMatch(FTransparentColor);
		6554	except
		6555	end;
		6556	end;
		6557	end;
		6558	end;
		6559
		6560	{ TPictureCollection }
		6561
		6562	constructor TPictureCollection.Create(AOwner: TPersistent);
		6563	begin
		6564	inherited Create(TPictureCollectionItem);
		6565	FOwner := AOwner;
		6566	end;
		6567
		6568	destructor TPictureCollection.Destroy;
		6569	begin
		6570	Finalize;
		6571	inherited Destroy;
		6572	end;
		6573
		6574	function TPictureCollection.GetItem(Index: Integer): TPictureCollectionItem;
		6575	begin
		6576	Result := TPictureCollectionItem(inherited Items[Index]);
		6577	end;
		6578
		6579	function TPictureCollection.GetOwner: TPersistent;
		6580	begin
		6581	Result := FOwner;
		6582	end;
		6583
		6584	function TPictureCollection.Find(const Name: string): TPictureCollectionItem;
		6585	var
		6586	i: Integer;
		6587	begin
		6588	i := IndexOf(Name);
		6589	if i=-1 then
		6590	raise EPictureCollectionError.CreateFmt(SImageNotFound, [Name]);
		6591	Result := Items[i];
		6592	end;
		6593
		6594	procedure TPictureCollection.Finalize;
		6595	var
		6596	i: Integer;
		6597	begin
		6598	try
		6599	for i:=0 to Count-1 do
		6600	Items[i].Finalize;
		6601	finally
		6602	FDXDraw := nil;
		6603	end;
		6604	end;
		6605
		6606	procedure TPictureCollection.Initialize(DXDraw: TCustomDXDraw);
		6607	var
		6608	i: Integer;
		6609	begin
		6610	Finalize;
		6611	FDXDraw := DXDraw;
		6612
		6613	if not Initialized then
		6614	raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
		6615
		6616	for i:=0 to Count-1 do
		6617	Items[i].Initialize;
		6618	end;
		6619
		6620	function TPictureCollection.Initialized: Boolean;
		6621	begin
		6622	Result := (FDXDraw<>nil) and (FDXDraw.Initialized);
		6623	end;
		6624
		6625	procedure TPictureCollection.Restore;
		6626	var
		6627	i: Integer;
		6628	begin
		6629	for i:=0 to Count-1 do
		6630	Items[i].Restore;
		6631	end;
		6632
		6633	procedure TPictureCollection.MakeColorTable;
		6634	var
		6635	UseColorTable: array[0..255] of Boolean;
		6636	PaletteCount: Integer;
		6637
		6638	procedure SetColor(Index: Integer; Col: TRGBQuad);
		6639	begin
		6640	UseColorTable[Index] := True;
		6641	ColorTable[Index] := Col;
		6642	Inc(PaletteCount);
		6643	end;
		6644
		6645	procedure AddColor(Col: TRGBQuad);
		6646	var
		6647	i: Integer;
		6648	begin
		6649	for i:=0 to 255 do
		6650	if UseColorTable[i] then
		6651	if DWORD(ColorTable[i])=DWORD(Col) then
		6652	Exit;
		6653	for i:=0 to 255 do
		6654	if not UseColorTable[i] then
		6655	begin
		6656	SetColor(i, Col);
		6657	Exit;
		6658	end;
		6659	end;
		6660
		6661	procedure AddDIB(DIB: TDIB);
		6662	var
		6663	i: Integer;
		6664	begin
		6665	if DIB.BitCount>8 then Exit;
		6666
		6667	for i:=0 to 255 do
		6668	AddColor(DIB.ColorTable[i]);
		6669	end;
		6670
		6671	procedure AddGraphic(Graphic: TGraphic);
		6672	var
		6673	i, n: Integer;
		6674	PaletteEntries: TPaletteEntries;
		6675	begin
		6676	if Graphic.Palette<>0 then
		6677	begin
		6678	n := GetPaletteEntries(Graphic.Palette, 0, 256, PaletteEntries);
		6679	for i:=0 to n-1 do
		6680	AddColor(PaletteEntryToRGBQuad(PaletteEntries[i]));
		6681	end;
		6682	end;
		6683
		6684	var
		6685	i: Integer;
		6686	begin
		6687	FillChar(UseColorTable, SizeOf(UseColorTable), 0);
		6688	FillChar(ColorTable, SizeOf(ColorTable), 0);
		6689
		6690	PaletteCount := 0;
		6691
		6692	{ The system color is included. }
		6693	SetColor(0, RGBQuad(0, 0, 0));
		6694	SetColor(1, RGBQuad(128, 0, 0));
		6695	SetColor(2, RGBQuad(0, 128, 0));
		6696	SetColor(3, RGBQuad(128, 128, 0));
		6697	SetColor(4, RGBQuad(0, 0, 128));
		6698	SetColor(5, RGBQuad(128, 0, 128));
		6699	SetColor(6, RGBQuad(0, 128, 128));
		6700	SetColor(7, RGBQuad(192, 192, 192));
		6701
		6702	SetColor(248, RGBQuad(128, 128, 128));
		6703	SetColor(249, RGBQuad(255, 0, 0));
		6704	SetColor(250, RGBQuad(0, 255, 0));
		6705	SetColor(251, RGBQuad(255, 255, 0));
		6706	SetColor(252, RGBQuad(0, 0, 255));
		6707	SetColor(253, RGBQuad(255, 0, 255));
		6708	SetColor(254, RGBQuad(0, 255, 255));
		6709	SetColor(255, RGBQuad(255, 255, 255));
		6710
		6711	for i:=0 to Count-1 do
		6712	if Items[i].Picture.Graphic<>nil then
		6713	begin
		6714	if Items[i].Picture.Graphic is TDIB then
		6715	AddDIB(TDIB(Items[i].Picture.Graphic))
		6716	else
		6717	AddGraphic(Items[i].Picture.Graphic);
		6718	if PaletteCount=256 then Break;
		6719	end;
		6720	end;
		6721
		6722	procedure TPictureCollection.DefineProperties(Filer: TFiler);
		6723	begin
		6724	inherited DefineProperties(Filer);
		6725	Filer.DefineBinaryProperty('ColorTable', ReadColorTable, WriteColorTable, True);
		6726	end;
		6727
		6728	type
		6729	TPictureCollectionComponent = class(TComponent)
		6730	private
		6731	FList: TPictureCollection;
		6732	published
		6733	property List: TPictureCollection read FList write FList;
		6734	end;
		6735
		6736	procedure TPictureCollection.LoadFromFile(const FileName: string);
		6737	var
		6738	Stream: TFileStream;
		6739	begin
		6740	Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
		6741	try
		6742	LoadFromStream(Stream);
		6743	finally
		6744	Stream.Free;
		6745	end;
		6746	end;
		6747
		6748	procedure TPictureCollection.LoadFromStream(Stream: TStream);
		6749	var
		6750	Component: TPictureCollectionComponent;
		6751	begin
		6752	Clear;
		6753	Component := TPictureCollectionComponent.Create(nil);
		6754	try
		6755	Component.FList := Self;
		6756	Stream.ReadComponentRes(Component);
		6757
		6758	if Initialized then
		6759	begin
		6760	Initialize(FDXDraw);
		6761	Restore;
		6762	end;
		6763	finally
		6764	Component.Free;
		6765	end;
		6766	end;
		6767
		6768	procedure TPictureCollection.SaveToFile(const FileName: string);
		6769	var
		6770	Stream: TFileStream;
		6771	begin
		6772	Stream := TFileStream.Create(FileName, fmCreate);
		6773	try
		6774	SaveToStream(Stream);
		6775	finally
		6776	Stream.Free;
		6777	end;
		6778	end;
		6779
		6780	procedure TPictureCollection.SaveToStream(Stream: TStream);
		6781	var
		6782	Component: TPictureCollectionComponent;
		6783	begin
		6784	Component := TPictureCollectionComponent.Create(nil);
		6785	try
		6786	Component.FList := Self;
		6787	Stream.WriteComponentRes('DelphiXPictureCollection', Component);
		6788	finally
		6789	Component.Free;
		6790	end;
		6791	end;
		6792
		6793	procedure TPictureCollection.ReadColorTable(Stream: TStream);
		6794	begin
		6795	Stream.ReadBuffer(ColorTable, SizeOf(ColorTable));
		6796	end;
		6797
		6798	procedure TPictureCollection.WriteColorTable(Stream: TStream);
		6799	begin
		6800	Stream.WriteBuffer(ColorTable, SizeOf(ColorTable));
		6801	end;
		6802
		6803	{ TCustomDXImageList }
		6804
		6805	constructor TCustomDXImageList.Create(AOnwer: TComponent);
		6806	begin
		6807	inherited Create(AOnwer);
		6808	FItems := TPictureCollection.Create(Self);
		6809	end;
		6810
		6811	destructor TCustomDXImageList.Destroy;
		6812	begin
		6813	DXDraw := nil;
		6814	FItems.Free;
		6815	inherited Destroy;
		6816	end;
		6817
		6818	procedure TCustomDXImageList.Notification(AComponent: TComponent;
		6819	Operation: TOperation);
		6820	begin
		6821	inherited Notification(AComponent, Operation);
		6822	if (Operation=opRemove) and (DXDraw=AComponent) then
		6823	DXDraw := nil;
		6824	end;
		6825
		6826	procedure TCustomDXImageList.DXDrawNotifyEvent(Sender: TCustomDXDraw;
		6827	NotifyType: TDXDrawNotifyType);
		6828	begin
		6829	case NotifyType of
		6830	dxntDestroying: DXDraw := nil;
		6831	dxntInitialize: FItems.Initialize(Sender);
		6832	dxntFinalize : FItems.Finalize;
		6833	dxntRestore : FItems.Restore;
		6834	end;
		6835	end;
		6836
		6837	procedure TCustomDXImageList.SetDXDraw(Value: TCustomDXDraw);
		6838	begin
		6839	if FDXDraw<>nil then
		6840	FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
		6841
		6842	FDXDraw := Value;
		6843
		6844	if FDXDraw<>nil then
		6845	FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
		6846	end;
		6847
		6848	procedure TCustomDXImageList.SetItems(Value: TPictureCollection);
		6849	begin
		6850	FItems.Assign(Value);
		6851	end;
		6852
		6853	{ TDirectDrawOverlay }
		6854
		6855	constructor TDirectDrawOverlay.Create(DDraw: TDirectDraw; TargetSurface: TDirectDrawSurface);
		6856	begin
		6857	inherited Create;
		6858	FDDraw := DDraw;
		6859	FTargetSurface := TargetSurface;
		6860	FVisible := True;
		6861	end;
		6862
		6863	constructor TDirectDrawOverlay.CreateWindowed(WindowHandle: HWND);
		6864	const
		6865	PrimaryDesc: TDDSurfaceDesc = (
		6866	dwSize: SizeOf(PrimaryDesc);
		6867	dwFlags: DDSD_CAPS;
		6868	ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
		6869	);
		6870	begin
		6871	FDDraw2 := TDirectDraw.CreateEx(nil, False);
		6872	if FDDraw2.IDraw.SetCooperativeLevel(WindowHandle, DDSCL_NORMAL)<>DD_OK then
		6873	raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
		6874
		6875	FTargetSurface2 := TDirectDrawSurface.Create(FDDraw2);
		6876	if not FTargetSurface2.CreateSurface(PrimaryDesc) then
		6877	raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
		6878
		6879	Create(FDDraw2, FTargetSurface2);
		6880	end;
		6881
		6882	destructor TDirectDrawOverlay.Destroy;
		6883	begin
		6884	Finalize;
		6885	FTargetSurface2.Free;
		6886	FDDraw2.Free;
		6887	inherited Destroy;
		6888	end;
		6889
		6890	procedure TDirectDrawOverlay.Finalize;
		6891	begin
		6892	FBackSurface.Free; FBackSurface := nil;
		6893	FSurface.Free; FSurface := nil;
		6894	end;
		6895
		6896	procedure TDirectDrawOverlay.Initialize(const SurfaceDesc: TDDSurfaceDesc);
		6897	const
		6898	BackBufferCaps: TDDSCaps = (dwCaps: DDSCAPS_BACKBUFFER);
		6899	var
		6900	DDSurface: IDirectDrawSurface;
		6901	begin
		6902	Finalize;
		6903	try
		6904	FSurface := TDirectDrawSurface.Create(FDDraw);
		6905	if not FSurface.CreateSurface(SurfaceDesc) then
		6906	raise EDirectDrawOverlayError.CreateFmt(SCannotInitialized, [SOverlay]);
		6907
		6908	FBackSurface := TDirectDrawSurface.Create(FDDraw);
		6909
		6910	if SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP<>0 then
		6911	begin
		6912	if FSurface.ISurface.GetAttachedSurface(BackBufferCaps, DDSurface)=DD_OK then
		6913	FBackSurface.IDDSurface := DDSurface;
		6914	end else
		6915	FBackSurface.IDDSurface := FSurface.IDDSurface;
		6916
		6917	if FVisible then
		6918	SetOverlayRect(FOverlayRect)
		6919	else
		6920	FSurface.ISurface.UpdateOverlay(PRect(nil)^, FTargetSurface.ISurface, PRect(nil)^, DDOVER_HIDE, PDDOverlayFX(nil)^);
		6921	except
		6922	Finalize;
		6923	raise;
		6924	end;
		6925	end;
		6926
		6927	procedure TDirectDrawOverlay.Flip;
		6928	begin
		6929	if FSurface=nil then Exit;
		6930
		6931	if FSurface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_FLIP<>0 then
		6932	FSurface.ISurface.Flip(nil, DDFLIP_WAIT);
		6933	end;
		6934
		6935	procedure TDirectDrawOverlay.SetOverlayColorKey(Value: TColor);
		6936	begin
		6937	FOverlayColorKey := Value;
		6938	if FSurface<>nil then
		6939	SetOverlayRect(FOverlayRect);
		6940	end;
		6941
		6942	procedure TDirectDrawOverlay.SetOverlayRect(const Value: TRect);
		6943	var
		6944	DestRect, SrcRect: TRect;
		6945	XScaleRatio, YScaleRatio: Integer;
		6946	OverlayFX: TDDOverlayFX;
		6947	OverlayFlags: DWORD;
		6948	begin
		6949	FOverlayRect := Value;
		6950	if (FSurface<>nil) and FVisible then
		6951	begin
		6952	DestRect := FOverlayRect;
		6953	SrcRect.Left := 0;
		6954	SrcRect.Top := 0;
		6955	SrcRect.Right := FSurface.SurfaceDesc.dwWidth;
		6956	SrcRect.Bottom := FSurface.SurfaceDesc.dwHeight;
		6957
		6958	OverlayFlags := DDOVER_SHOW;
		6959
		6960	FillChar(OverlayFX, SizeOf(OverlayFX), 0);
		6961	OverlayFX.dwSize := SizeOf(OverlayFX);
		6962
		6963	{ Scale rate limitation }
		6964	XScaleRatio := (DestRect.right - DestRect.left) * 1000 div (SrcRect.right - SrcRect.left);
		6965	YScaleRatio := (DestRect.bottom - DestRect.top) * 1000 div (SrcRect.bottom - SrcRect.top);
		6966
		6967	if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH<>0) and
		6968	(FDDraw.DriverCaps.dwMinOverlayStretch<>0) and (XScaleRatio<Integer(FDDraw.DriverCaps.dwMinOverlayStretch)) then
		6969	begin
		6970	DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
		6971	end;
		6972
		6973	if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH<>0) and
		6974	(FDDraw.DriverCaps.dwMaxOverlayStretch<>0) and (XScaleRatio>Integer(FDDraw.DriverCaps.dwMaxOverlayStretch)) then
		6975	begin
		6976	DestRect.Right := DestRect.Left + (Integer(FSurface.SurfaceDesc.dwWidth) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
		6977	end;
		6978
		6979	if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH<>0) and
		6980	(FDDraw.DriverCaps.dwMinOverlayStretch<>0) and (YScaleRatio<Integer(FDDraw.DriverCaps.dwMinOverlayStretch)) then
		6981	begin
		6982	DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMinOverlayStretch) + 1)) div 1000;
		6983	end;
		6984
		6985	if (FDDraw.DriverCaps.dwCaps and DDCAPS_OVERLAYSTRETCH<>0) and
		6986	(FDDraw.DriverCaps.dwMaxOverlayStretch<>0) and (YScaleRatio>Integer(FDDraw.DriverCaps.dwMaxOverlayStretch)) then
		6987	begin
		6988	DestRect.Bottom := DestRect.Top + (Integer(FSurface.SurfaceDesc.dwHeight) * (Integer(FDDraw.DriverCaps.dwMaxOverlayStretch) + 999)) div 1000;
		6989	end;
		6990
		6991	{ Clipping at forwarding destination }
		6992	XScaleRatio := (DestRect.Right - DestRect.Left) * 1000 div (SrcRect.Right - SrcRect.Left);
		6993	YScaleRatio := (DestRect.Bottom - DestRect.Top) * 1000 div (SrcRect.Bottom - SrcRect.Top);
		6994
		6995	if DestRect.Top < 0 then
		6996	begin
		6997	SrcRect.Top := -DestRect.Top * 1000 div YScaleRatio;
		6998	DestRect.Top := 0;
		6999	end;
		7000
		7001	if DestRect.Left < 0 then
		7002	begin
		7003	SrcRect.Left := -DestRect.Left * 1000 div XScaleRatio;
		7004	DestRect.Left := 0;
		7005	end;
		7006
		7007	if DestRect.Right > Integer(FTargetSurface.SurfaceDesc.dwWidth) then
		7008	begin
		7009	SrcRect.Right := Integer(FSurface.SurfaceDesc.dwWidth) - ((DestRect.Right - Integer(FTargetSurface.SurfaceDesc.dwWidth)) * 1000 div XScaleRatio);
		7010	DestRect.Right := FTargetSurface.SurfaceDesc.dwWidth;
		7011	end;
		7012
		7013	if DestRect.Bottom > Integer(FTargetSurface.SurfaceDesc.dwHeight) then
		7014	begin
		7015	SrcRect.Bottom := Integer(FSurface.SurfaceDesc.dwHeight) - ((DestRect.Bottom - Integer(FTargetSurface.SurfaceDesc.dwHeight)) * 1000 div YScaleRatio);
		7016	DestRect.Bottom := FTargetSurface.SurfaceDesc.dwHeight;
		7017	end;
		7018
		7019	{ Forwarding former arrangement }
		7020	if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYSRC<>0) and (FDDraw.DriverCaps.dwAlignBoundarySrc<>0) then
		7021	begin
		7022	SrcRect.Left := (SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundarySrc) div 2) div
		7023	Integer(FDDraw.DriverCaps.dwAlignBoundarySrc)*Integer(FDDraw.DriverCaps.dwAlignBoundarySrc);
		7024	end;
		7025
		7026	if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZESRC<>0) and (FDDraw.DriverCaps.dwAlignSizeSrc<>0) then
		7027	begin
		7028	SrcRect.Right := SrcRect.Left + (SrcRect.Right - SrcRect.Left + Integer(FDDraw.DriverCaps.dwAlignSizeSrc) div 2) div
		7029	Integer(FDDraw.DriverCaps.dwAlignSizeSrc)*Integer(FDDraw.DriverCaps.dwAlignSizeSrc);
		7030	end;
		7031
		7032	{ Forwarding destination arrangement }
		7033	if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNBOUNDARYDEST<>0) and (FDDraw.DriverCaps.dwAlignBoundaryDest<>0) then
		7034	begin
		7035	DestRect.Left := (DestRect.Left + Integer(FDDraw.DriverCaps.dwAlignBoundaryDest) div 2) div
		7036	Integer(FDDraw.DriverCaps.dwAlignBoundaryDest)*Integer(FDDraw.DriverCaps.dwAlignBoundaryDest);
		7037	end;
		7038
		7039	if (FDDraw.DriverCaps.dwCaps and DDCAPS_ALIGNSIZEDEST<>0) and (FDDraw.DriverCaps.dwAlignSizeDest<>0) then
		7040	begin
		7041	DestRect.Right := DestRect.Left + (DestRect.Right - DestRect.Left) div
		7042	Integer(FDDraw.DriverCaps.dwAlignSizeDest)*Integer(FDDraw.DriverCaps.dwAlignSizeDest);
		7043	end;
		7044
		7045	{ Color key setting }
		7046	if FDDraw.DriverCaps.dwCKeyCaps and DDCKEYCAPS_DESTOVERLAY<>0 then
		7047	begin
		7048	OverlayFX.dckDestColorkey.dwColorSpaceLowValue := FTargetSurface.ColorMatch(FOverlayColorKey);
		7049	OverlayFX.dckDestColorkey.dwColorSpaceHighValue := OverlayFX.dckDestColorkey.dwColorSpaceLowValue;
		7050
		7051	OverlayFlags := OverlayFlags or (DDOVER_KEYDESTOVERRIDE or DDOVER_DDFX);
		7052	end;
		7053
		7054	FSurface.ISurface.UpdateOverlay(SrcRect, FTargetSurface.ISurface, DestRect, OverlayFlags, OverlayFX);
		7055	end;
		7056	end;
		7057
		7058	procedure TDirectDrawOverlay.SetVisible(Value: Boolean);
		7059	begin
		7060	FVisible := False;
		7061	if FSurface<>nil then
		7062	begin
		7063	if FVisible then
		7064	SetOverlayRect(FOverlayRect)
		7065	else
		7066	FSurface.ISurface.UpdateOverlay(PRect(nil)^, FTargetSurface.ISurface, PRect(nil)^, DDOVER_HIDE, PDDOverlayFX(nil)^);
		7067	end;
		7068	end;
		7069
		7070	initialization
		7071	finalization
		7072	DirectDrawDrivers.Free;
		7073	end.
		7074
		7075

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXDraws.pas – Rev 1