Subversion Repositories spacemission

Rev

Rev 4 | Go to most recent revision | Blame | Compare with Previous | Last modification | View Log | RSS feed

  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)+Y*ddsd.lPitch+X*2)^;
  2444.           24: with PRGB(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*3)^ do
  2445.                 Result := R or (G shl 8) or (B shl 16);
  2446.           32: Result := PInteger(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*4)^;
  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)+Y*ddsd.lPitch+X*2)^ := Value;
  2653.           24: with PRGB(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*3)^ 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)+Y*ddsd.lPitch+X*4)^ := 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 := FNowOptions*InitOptions+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.lPitch*y+x*2)^ := c;
  5971.       24: begin
  5972.             PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x*3)^ := c shr 0;
  5973.             PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x*3+1)^ := c shr 8;
  5974.             PByte(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x*3+2)^ := c shr 16;
  5975.           end;  
  5976.       32: PDWORD(Integer(ddsd.lpSurface)+ddsd.lPitch*y+x*4)^ := 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.lPitch*y)^, (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.lPitch*y)^, (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(x*BlockWidth, y*BlockHeight, 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 BlockWidth*BlockWidth), y2-(y2 div BlockHeight*BlockHeight), 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.  
  7076.