home *** CD-ROM | disk | FTP | other *** search
/ io Programmo 23 / IOPROG_23.ISO / SOFT / DELPHIX.ZIP / Source / DXDraws.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1998-10-06  |  166.3 KB  |  5,692 lines
  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, 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.     FDriverCaps: DDCAPS;
  31.     FHELCaps: DDCAPS;
  32.     FClippers: TList;
  33.     FPalettes: TList;
  34.     FSurfaces: TList;
  35.     function GetClipper(Index: Integer): TDirectDrawClipper;
  36.     function GetClipperCount: Integer;
  37.     function GetDisplayMode: DDSURFACEDESC;
  38.     function GetIDDraw: IDirectDraw;
  39.     function GetIDDraw4: IDirectDraw4;
  40.     function GetIDraw: IDirectDraw;
  41.     function GetIDraw4: IDirectDraw4;
  42.     function GetPalette(Index: Integer): TDirectDrawPalette;
  43.     function GetPaletteCount: Integer;
  44.     function GetSurface(Index: Integer): TDirectDrawSurface;
  45.     function GetSurfaceCount: Integer;
  46.   public
  47.     constructor Create(GUID: PGUID);
  48.     constructor CreateFromInterface(DDraw: IDirectDraw);
  49.     destructor Destroy; override;
  50.     class function Drivers: TDirectXDrivers;
  51.     property ClipperCount: Integer read GetClipperCount;
  52.     property Clippers[Index: Integer]: TDirectDrawClipper read GetClipper;
  53.     property DisplayMode: DDSURFACEDESC read GetDisplayMode;
  54.     property DriverCaps: DDCAPS read FDriverCaps;
  55.     property HELCaps: DDCAPS read FHELCaps;
  56.     property IDDraw: IDirectDraw read GetIDDraw;
  57.     property IDDraw4: IDirectDraw4 read GetIDDraw4;
  58.     property IDraw: IDirectDraw read GetIDraw;
  59.     property IDraw4: IDirectDraw4 read GetIDraw4;
  60.     property PaletteCount: Integer read GetPaletteCount;
  61.     property Palettes[Index: Integer]: TDirectDrawPalette read GetPalette;
  62.     property SurfaceCount: Integer read GetSurfaceCount;
  63.     property Surfaces[Index: Integer]: TDirectDrawSurface read GetSurface;
  64.   end;
  65.  
  66.   {  TDirectDrawPalette  }
  67.  
  68.   TDirectDrawPalette = class(TDirectX)
  69.   private
  70.     FDDraw: TDirectDraw;
  71.     FIDDPalette: IDirectDrawPalette;
  72.     function GetEntry(Index: Integer): TPaletteEntry;
  73.     function GetIDDPalette: IDirectDrawPalette;
  74.     function GetIPalette: IDirectDrawPalette;
  75.     procedure SetEntry(Index: Integer; Value: TPaletteEntry);
  76.     procedure SetIDDPalette(Value: IDirectDrawPalette);
  77.   public
  78.     constructor Create(ADirectDraw: TDirectDraw);
  79.     destructor Destroy; override;
  80.     function CreatePalette(Caps: Integer; const Entries): Boolean;
  81.     function GetEntries(StartIndex, NumEntries: Integer; var Entries): Boolean;
  82.     procedure LoadFromDIB(DIB: TDIB);
  83.     procedure LoadFromFile(const FileName: string);
  84.     procedure LoadFromStream(Stream: TStream);
  85.     function SetEntries(StartIndex, NumEntries: Integer; const Entries): Boolean;
  86.     property DDraw: TDirectDraw read FDDraw;
  87.     property Entries[Index: Integer]: TPaletteEntry read GetEntry write SetEntry;
  88.     property IDDPalette: IDirectDrawPalette read GetIDDPalette write SetIDDPalette;
  89.     property IPalette: IDirectDrawPalette read GetIPalette;
  90.   end;
  91.  
  92.   {  TDirectDrawClipper  }
  93.  
  94.   TDirectDrawClipper = class(TDirectX)
  95.   private
  96.     FDDraw: TDirectDraw;
  97.     FIDDClipper: IDirectDrawClipper;
  98.     function GetIDDClipper: IDirectDrawClipper;
  99.     function GetIClipper: IDirectDrawClipper;
  100.     procedure SetHandle(Value: THandle);
  101.     procedure SetIDDClipper(Value: IDirectDrawClipper);
  102.     property Handle: THandle write SetHandle;
  103.   public
  104.     constructor Create(ADirectDraw: TDirectDraw);
  105.     destructor Destroy; override;
  106.     procedure SetClipRects(const Rects: array of TRect);
  107.     property DDraw: TDirectDraw read FDDraw;
  108.     property IClipper: IDirectDrawClipper read GetIClipper;
  109.     property IDDClipper: IDirectDrawClipper read GetIDDClipper write SetIDDClipper;
  110.   end;
  111.  
  112.   {  TDirectDrawSurfaceCanvas  }
  113.  
  114.   TDirectDrawSurfaceCanvas = class(TCanvas)
  115.   private
  116.     FDC: HDC;
  117.     FSurface: TDirectDrawSurface;
  118.   protected
  119.     procedure CreateHandle; override;
  120.   public
  121.     constructor Create(ASurface: TDirectDrawSurface);
  122.     destructor Destroy; override;
  123.     procedure Release;
  124.   end;
  125.  
  126.   {  TDirectDrawSurface  }
  127.  
  128.   TDirectDrawSurface = class(TDirectX)
  129.   private
  130.     FCanvas: TDirectDrawSurfaceCanvas;
  131.     FHasClipper: Boolean;
  132.     FDDraw: TDirectDraw;
  133.     FIDDSurface: IDirectDrawSurface;
  134.     FIDDSurface4: IDirectDrawSurface4;
  135.     FSystemMemory: Boolean;
  136.     FStretchDrawClipper: IDirectDrawClipper;
  137.     FSurfaceDesc: DDSURFACEDESC;
  138.     FGammaControl: IDirectDrawGammaControl;
  139.     function GetBitCount: Integer;
  140.     function GetCanvas: TDirectDrawSurfaceCanvas;
  141.     function GetClientRect: TRect;
  142.     function GetHeight: Integer;
  143.     function GetIDDSurface: IDirectDrawSurface;
  144.     function GetIDDSurface4: IDirectDrawSurface4;
  145.     function GetISurface: IDirectDrawSurface;
  146.     function GetISurface4: IDirectDrawSurface4;
  147.     function GetPixel(X, Y: Integer): Longint;
  148.     function GetWidth: Integer;
  149.     procedure SetClipper(Value: TDirectDrawClipper);
  150.     procedure SetColorKey(Flags: Integer; const Value: DDCOLORKEY);
  151.     procedure SetIDDSurface(Value: IDirectDrawSurface);
  152.     procedure SetIDDSurface4(Value: IDirectDrawSurface4);
  153.     procedure SetPalette(Value: TDirectDrawPalette);
  154.     procedure SetPixel(X, Y: Integer; Value: Longint);
  155.     procedure SetTransparentColor(Col: Longint);
  156.   public
  157.     constructor Create(ADirectDraw: TDirectDraw);
  158.     destructor Destroy; override;
  159.     procedure Assign(Source: TPersistent); override;
  160.     procedure AssignTo(Dest: TPersistent); override;
  161.     function Blt(const DestRect, SrcRect: TRect; Flags: Integer;
  162.       const DF: DDBLTFX; Source: TDirectDrawSurface): Boolean;
  163.     function BltFast(X, Y: Integer; const SrcRect: TRect;
  164.       Flags: Integer; Source: TDirectDrawSurface): Boolean;
  165.     function ColorMatch(Col: TColor): Integer;
  166. {$IFDEF DelphiX_Delphi4}
  167.     function CreateSurface(const SurfaceDesc: DDSURFACEDESC): Boolean; overload;
  168.     function CreateSurface(const SurfaceDesc: DDSURFACEDESC2): Boolean; overload;
  169. {$ELSE}
  170.     function CreateSurface(const SurfaceDesc: DDSURFACEDESC): Boolean;
  171. {$ENDIF}
  172. {$IFDEF DelphiX_Delphi4}
  173.     procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean=True); overload;
  174.     procedure Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean=True); overload;
  175.     procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  176.       Transparent: Boolean=True); overload;
  177.     procedure StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
  178.       Transparent: Boolean=True); overload;
  179. {$ELSE}
  180.     procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
  181.       Transparent: Boolean);
  182.     procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  183.       Transparent: Boolean);
  184. {$ENDIF}
  185.     procedure DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  186.       Transparent: Boolean; Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  187.     procedure DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  188.       Transparent: Boolean; Alpha: Integer);
  189.     procedure DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  190.       Transparent: Boolean; Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  191.     procedure DrawRotate(X, Y, Width, Height: Integer; SrcRect: TRect;
  192.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer);
  193.     procedure DrawRotateAdd(X, Y, Width, Height: Integer; SrcRect: TRect;
  194.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
  195.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  196.     procedure DrawRotateAlpha(X, Y, Width, Height: Integer; SrcRect: TRect;
  197.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
  198.       Alpha: Integer);
  199.     procedure DrawRotateSub(X, Y, Width, Height: Integer; SrcRect: TRect;
  200.       Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
  201.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  202.     procedure DrawWaveX(X, Y, Width, Height: Integer; SrcRect: TRect;
  203.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
  204.     procedure DrawWaveXAdd(X, Y, Width, Height: Integer; SrcRect: TRect;
  205.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  206.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  207.     procedure DrawWaveXAlpha(X, Y, Width, Height: Integer; SrcRect: TRect;
  208.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  209.       Alpha: Integer);
  210.     procedure DrawWaveXSub(X, Y, Width, Height: Integer; SrcRect: TRect;
  211.       Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer;
  212.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  213.     procedure Fill(DevCol: Longint);
  214.     procedure FillRect(const Rect: TRect; DevCol: Longint);
  215.     procedure FillRectAdd(const DestRect: TRect; RGBCol: TColor);
  216.     procedure FillRectAlpha(const DestRect: TRect; RGBCol: TColor; Alpha: Integer);
  217.     procedure FillRectSub(const DestRect: TRect; RGBCol: TColor);
  218.     procedure LoadFromDIB(DIB: TDIB);
  219.     procedure LoadFromDIBRect(DIB: TDIB; AWidth, AHeight: Integer; const SrcRect: TRect);
  220.     procedure LoadFromGraphic(Graphic: TGraphic);
  221.     procedure LoadFromGraphicRect(Graphic: TGraphic; AWidth, AHeight: Integer; const SrcRect: TRect);
  222.     procedure LoadFromFile(const FileName: string);
  223.     procedure LoadFromStream(Stream: TStream);
  224. {$IFDEF DelphiX_Delphi4}
  225.     function Lock(const Rect: TRect; var SurfaceDesc: DDSURFACEDESC): Boolean; overload;
  226.     function Lock(var SurfaceDesc: DDSURFACEDESC): Boolean; overload;
  227. {$ELSE}
  228.     function Lock(const Rect: TRect; var SurfaceDesc: DDSURFACEDESC): Boolean;
  229. {$ENDIF}
  230.     procedure UnLock(lpSurfaceData: Pointer);
  231.     function Restore: Boolean;
  232.     procedure SetSize(AWidth, AHeight: Integer);
  233.     property BitCount: Integer read GetBitCount;
  234.     property Canvas: TDirectDrawSurfaceCanvas read GetCanvas;
  235.     property ClientRect: TRect read GetClientRect;
  236.     property Clipper: TDirectDrawClipper write SetClipper;
  237.     property ColorKey[Flags: Integer]: DDCOLORKEY write SetColorKey;
  238.     property DDraw: TDirectDraw read FDDraw;
  239.     property GammaControl: IDirectDrawGammaControl read FGammaControl;
  240.     property Height: Integer read GetHeight;
  241.     property IDDSurface: IDirectDrawSurface read GetIDDSurface write SetIDDSurface;
  242.     property IDDSurface4: IDirectDrawSurface4 read GetIDDSurface4 write SetIDDSurface4;
  243.     property ISurface: IDirectDrawSurface read GetISurface;
  244.     property ISurface4: IDirectDrawSurface4 read GetISurface4;
  245.     property Palette: TDirectDrawPalette write SetPalette;
  246.     property Pixels[X, Y: Integer]: Longint read GetPixel write SetPixel;
  247.     property SurfaceDesc: DDSURFACEDESC read FSurfaceDesc;
  248.     property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
  249.     property TransparentColor: Longint write SetTransparentColor;
  250.     property Width: Integer read GetWidth;
  251.   end;
  252.  
  253.   {  TDirectDrawDisplay  }
  254.  
  255.   TCustomDXDraw = class;
  256.  
  257.   TDirectDrawDisplayMode = class(TCollectionItem)
  258.   private
  259.     FSurfaceDesc: DDSURFACEDESC;
  260.     function GetBitCount: Integer;
  261.     function GetHeight: Integer;
  262.     function GetWidth: Integer;
  263.   public
  264.     property BitCount: Integer read GetBitCount;
  265.     property Height: Integer read GetHeight;
  266.     property SurfaceDesc: DDSURFACEDESC read FSurfaceDesc;
  267.     property Width: Integer read GetWidth;
  268.   end;
  269.  
  270.   TDirectDrawDisplay = class(TPersistent)
  271.   private
  272.     FBitCount: Integer;
  273.     FDXDraw: TCustomDXDraw;
  274.     FHeight: Integer;
  275.     FModes: TCollection;
  276.     FWidth: Integer;
  277.     FFixedBitCount: Boolean;
  278.     FFixedRatio: Boolean;
  279.     FFixedSize: Boolean;
  280.     function GetCount: Integer;
  281.     function GetMode: TDirectDrawDisplayMode;
  282.     function GetMode2(Index: Integer): TDirectDrawDisplayMode;
  283.     procedure LoadDisplayModes;
  284.     procedure SetBitCount(Value: Integer);
  285.     procedure SetHeight(Value: Integer);
  286.     procedure SetWidth(Value: Integer);
  287.     function SetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  288.     function DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  289.   public
  290.     constructor Create(ADXDraw: TCustomDXDraw);
  291.     destructor Destroy; override;
  292.     procedure Assign(Source: TPersistent); override;
  293.     function IndexOf(Width, Height, BitCount: Integer): Integer;
  294.     property Count: Integer read GetCount;
  295.     property Mode: TDirectDrawDisplayMode read GetMode;
  296.     property Modes[Index: Integer]: TDirectDrawDisplayMode read GetMode2; default;
  297.   published
  298.     property BitCount: Integer read FBitCount write SetBitCount default 8;
  299.     property FixedBitCount: Boolean read FFixedBitCount write FFixedBitCount;
  300.     property FixedRatio: Boolean read FFixedRatio write FFixedRatio;
  301.     property FixedSize: Boolean read FFixedSize write FFixedSize;
  302.     property Height: Integer read FHeight write SetHeight default 480;
  303.     property Width: Integer read FWidth write SetWidth default 640;
  304.   end;
  305.  
  306.   {  EDXDrawError  }
  307.  
  308.   EDXDrawError = class(Exception);
  309.  
  310.   {  TCustomDXDraw  }
  311.  
  312.   TDXDrawOption = (doFullScreen, doNoWindowChange, doAllowReboot, doWaitVBlank,
  313.     doAllowPalette256, doSystemMemory, doStretch, doCenter, doFlip, do3D,
  314.     doHardware, doRetainedMode, doSelectDriver, doZBuffer,
  315.     doRGB, doMono, doDither);
  316.                                                       
  317.   TDXDrawOptions = set of TDXDrawOption;
  318.  
  319.   TDXDrawNotifyType = (dxntDestroying, dxntInitializing, dxntInitialize, dxntInitializeSurface,
  320.     dxntFinalize, dxntFinalizeSurface, dxntRestore, dxntSetSurfaceSize);
  321.  
  322.   TDXDrawNotifyEvent = procedure(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType) of object;
  323.  
  324.   TCustomDXDraw = class(TCustomControl)
  325.   private
  326.     FAutoInitialize: Boolean;
  327.     FAutoSize: Boolean;
  328.     FCalledDoInitialize: Boolean;
  329.     FCalledDoInitializeSurface: Boolean;
  330.     FForm: TCustomForm;
  331.     FNotifyEventList: TList;
  332.     FInitialized: Boolean;
  333.     FInitialized2: Boolean;
  334.     FInternalInitialized: Boolean;
  335.     FUpdating: Boolean;
  336.     FSubClass: TControlSubClass;
  337.     FNowOptions: TDXDrawOptions;
  338.     FOptions: TDXDrawOptions;
  339.     FOnFinalize: TNotifyEvent;
  340.     FOnFinalizeSurface: TNotifyEvent;
  341.     FOnInitialize: TNotifyEvent;
  342.     FOnInitializeSurface: TNotifyEvent;
  343.     FOnInitializing: TNotifyEvent;
  344.     FOnRestoreSurface: TNotifyEvent;
  345.     FOffNotifyRestore: Integer;
  346.     { DirectDraw }
  347.     FDXDrawDriver: TObject;
  348.     FDriver: PGUID;
  349.     FDriverGUID: TGUID;
  350.     FDDraw: TDirectDraw;
  351.     FDisplay: TDirectDrawDisplay;
  352.     FClipper: TDirectDrawClipper;
  353.     FPalette: TDirectDrawPalette;
  354.     FPrimary: TDirectDrawSurface;
  355.     FSurface: TDirectDrawSurface;
  356.     FSurfaceWidth: Integer;
  357.     FSurfaceHeight: Integer;
  358.     { Direct3D }
  359.     FD3D: IDirect3D;
  360.     FD3D2: IDirect3D2;
  361.     FD3D3: IDirect3D3;
  362.     FD3DDevice: IDirect3DDevice;
  363.     FD3DDevice2: IDirect3DDevice2;
  364.     FD3DDevice3: IDirect3DDevice3;
  365.     FD3DRM: IDirect3DRM;
  366.     FD3DRM2: IDirect3DRM2;
  367.     FD3DRMDevice: IDirect3DRMDevice;
  368.     FD3DRMDevice2: IDirect3DRMDevice2;
  369.     FCamera: IDirect3DRMFrame;
  370.     FScene: IDirect3DRMFrame;
  371.     FViewport: IDirect3DRMViewport;
  372.     FZBuffer: TDirectDrawSurface;
  373.     FHWDeviceDesc, FHELDeviceDesc, FD3DDeviceDesc: D3DDEVICEDESC;
  374.     procedure FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  375.     function GetCanDraw: Boolean;
  376.     function GetCanPaletteAnimation: Boolean;
  377.     function GetSurfaceHeight: Integer;
  378.     function GetSurfaceWidth: Integer;
  379.     procedure NotifyEventList(NotifyType: TDXDrawNotifyType);
  380.     procedure SetAutoSize(Value: Boolean);
  381.     procedure SetColorTable(const ColorTable: TRGBQuads);
  382.     procedure SetCooperativeLevel;
  383.     procedure SetDisplay(Value: TDirectDrawDisplay);
  384.     procedure SetDriver(Value: PGUID);
  385.     procedure SetOptions(Value: TDXDrawOptions);
  386.     procedure SetSurfaceHeight(Value: Integer);
  387.     procedure SetSurfaceWidth(Value: Integer);
  388.     function TryRestore: Boolean;
  389.     procedure WMCreate(var Message: TMessage); message WM_CREATE;
  390.   protected
  391.     procedure DoFinalize; virtual;
  392.     procedure DoFinalizeSurface; virtual;
  393.     procedure DoInitialize; virtual;
  394.     procedure DoInitializeSurface; virtual;
  395.     procedure DoInitializing; virtual;
  396.     procedure DoRestoreSurface; virtual;
  397.     procedure Loaded; override;
  398.     procedure Paint; override;
  399.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  400.     procedure SetParent(AParent: TWinControl); override;
  401.   public
  402.     ColorTable: TRGBQuads;
  403.     DefColorTable: TRGBQuads;
  404.     constructor Create(AOwner: TComponent); override;
  405.     destructor Destroy; override;
  406.     class function Drivers: TDirectXDrivers;
  407.     procedure Finalize;
  408.     procedure Flip;
  409.     procedure Initialize;
  410.     procedure Render;
  411.     procedure Restore;
  412.     procedure Setbounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  413.     procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  414.     procedure UpdatePalette;
  415.     procedure RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  416.     procedure UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  417.     property AutoInitialize: Boolean read FAutoInitialize write FAutoInitialize;
  418.     property AutoSize: Boolean read FAutoSize write SetAutoSize;
  419.     property Camera: IDirect3DRMFrame read FCamera;
  420.     property CanDraw: Boolean read GetCanDraw;
  421.     property CanPaletteAnimation: Boolean read GetCanPaletteAnimation;
  422.     property Clipper: TDirectDrawClipper read FClipper;
  423.     property Color;
  424.     property D3D: IDirect3D read FD3D;
  425.     property D3D2: IDirect3D2 read FD3D2;
  426.     property D3D3: IDirect3D3 read FD3D3;
  427.     property D3DDevice: IDirect3DDevice read FD3DDevice;
  428.     property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
  429.     property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
  430.     property D3DRM: IDirect3DRM read FD3DRM;
  431.     property D3DRM2: IDirect3DRM2 read FD3DRM2;
  432.     property D3DRMDevice: IDirect3DRMDevice read FD3DRMDevice;
  433.     property D3DRMDevice2: IDirect3DRMDevice2 read FD3DRMDevice2;
  434.     property DDraw: TDirectDraw read FDDraw;
  435.     property Display: TDirectDrawDisplay read FDisplay write SetDisplay;
  436.     property Driver: PGUID read FDriver write SetDriver;
  437.     property Initialized: Boolean read FInitialized;
  438.     property NowOptions: TDXDrawOptions read FNowOptions;
  439.     property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
  440.     property OnFinalizeSurface: TNotifyEvent read FOnFinalizeSurface write FOnFinalizeSurface;
  441.     property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
  442.     property OnInitializeSurface: TNotifyEvent read FOnInitializeSurface write FOnInitializeSurface;
  443.     property OnInitializing: TNotifyEvent read FOnInitializing write FOnInitializing;
  444.     property OnRestoreSurface: TNotifyEvent read FOnRestoreSurface write FOnRestoreSurface;
  445.     property Options: TDXDrawOptions read FOptions write SetOptions;
  446.     property Palette: TDirectDrawPalette read FPalette;
  447.     property Primary: TDirectDrawSurface read FPrimary;
  448.     property Scene: IDirect3DRMFrame read FScene;
  449.     property Surface: TDirectDrawSurface read FSurface;
  450.     property SurfaceHeight: Integer read GetSurfaceHeight write SetSurfaceHeight default 480;
  451.     property SurfaceWidth: Integer read GetSurfaceWidth write SetSurfaceWidth default 640;
  452.     property Viewport: IDirect3DRMViewport read FViewport;
  453.     property ZBuffer: TDirectDrawSurface read FZBuffer;
  454.   end;
  455.  
  456.   {  TDXDraw  }
  457.  
  458.   TDXDraw = class(TCustomDXDraw)
  459.   published
  460.     property AutoInitialize;
  461.     property AutoSize;
  462.     property Color;
  463.     property Display;
  464.     property Options;
  465.     property SurfaceHeight;
  466.     property SurfaceWidth;
  467.     property OnFinalize;
  468.     property OnFinalizeSurface;
  469.     property OnInitialize;
  470.     property OnInitializeSurface;
  471.     property OnInitializing;
  472.     property OnRestoreSurface;
  473.     property Align;
  474.     property DragCursor;
  475.     property DragMode;
  476.     property Enabled;
  477.     property ParentShowHint;
  478.     property PopupMenu;
  479.     property ShowHint;
  480.     property TabOrder;
  481.     property TabStop;
  482.     property Visible;
  483.     property OnClick;
  484.     property OnDblClick;
  485.     property OnDragDrop;
  486.     property OnDragOver;
  487.     property OnEndDrag;
  488.     property OnEnter;
  489.     property OnExit;
  490.     property OnKeyDown;
  491.     property OnKeyPress;
  492.     property OnKeyUp;
  493.     property OnMouseDown;
  494.     property OnMouseMove;
  495.     property OnMouseUp;
  496.     property OnStartDrag;
  497.   end;
  498.  
  499.   {  EDX3DError  }
  500.  
  501.   EDX3DError = class(Exception);
  502.  
  503.   {  TCustomDX3D  }
  504.  
  505.   TDX3DOption = (toSystemMemory, toHardware, toRetainedMode,
  506.     toSelectDriver, toZBuffer, toRGB, toMono, toDither);
  507.  
  508.   TDX3DOptions = set of TDX3DOption;
  509.  
  510.   TCustomDX3D = class(TComponent)
  511.   private
  512.     FAutoSize: Boolean;
  513.     FCamera: IDirect3DRMFrame;
  514.     FD3D: IDirect3D;
  515.     FD3D2: IDirect3D2;
  516.     FD3D3: IDirect3D3;
  517.     FD3DDevice: IDirect3DDevice;
  518.     FD3DDevice2: IDirect3DDevice2;
  519.     FD3DDevice3: IDirect3DDevice3;
  520.     FD3DRM: IDirect3DRM;
  521.     FD3DRM2: IDirect3DRM2;
  522.     FD3DRMDevice: IDirect3DRMDevice;
  523.     FD3DRMDevice2: IDirect3DRMDevice2;
  524.     FDXDraw: TCustomDXDraw;
  525.     FInitFlag: Boolean;
  526.     FInitialized: Boolean;
  527.     FNowOptions: TDX3DOptions;
  528.     FOnFinalize: TNotifyEvent;
  529.     FOnInitialize: TNotifyEvent;
  530.     FOptions: TDX3DOptions;
  531.     FScene: IDirect3DRMFrame;
  532.     FSurface: TDirectDrawSurface;
  533.     FSurfaceHeight: Integer;
  534.     FSurfaceWidth: Integer;
  535.     FViewport: IDirect3DRMViewport;
  536.     FZBuffer: TDirectDrawSurface;
  537.     FHWDeviceDesc, FHELDeviceDesc, FD3DDeviceDesc: D3DDEVICEDESC;
  538.     procedure Finalize;
  539.     procedure Initialize;
  540.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  541.     function GetCanDraw: Boolean;
  542.     function GetHardware: Boolean;
  543.     function GetSurfaceHeight: Integer;
  544.     function GetSurfaceWidth: Integer;
  545.     procedure SetAutoSize(Value: Boolean);
  546.     procedure SetDXDraw(Value: TCustomDXDraw);
  547.     procedure SetOptions(Value: TDX3DOptions); virtual;
  548.     procedure SetSurfaceHeight(Value: Integer);
  549.     procedure SetSurfaceWidth(Value: Integer);
  550.   protected
  551.     procedure DoFinalize; virtual;
  552.     procedure DoInitialize; virtual;
  553.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  554.   public
  555.     constructor Create(AOwner: TComponent); override;
  556.     destructor Destroy; override;
  557.     procedure Render;
  558.     procedure SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  559.     property AutoSize: Boolean read FAutoSize write SetAutoSize;
  560.     property CanDraw: Boolean read GetCanDraw;
  561.     property Camera: IDirect3DRMFrame read FCamera;
  562.     property D3D: IDirect3D read FD3D;
  563.     property D3D2: IDirect3D2 read FD3D2;
  564.     property D3D3: IDirect3D3 read FD3D3;
  565.     property D3DDevice: IDirect3DDevice read FD3DDevice;
  566.     property D3DDevice2: IDirect3DDevice2 read FD3DDevice2;
  567.     property D3DDevice3: IDirect3DDevice3 read FD3DDevice3;
  568.     property D3DRM: IDirect3DRM read FD3DRM;
  569.     property D3DRM2: IDirect3DRM2 read FD3DRM2;
  570.     property D3DRMDevice: IDirect3DRMDevice read FD3DRMDevice;
  571.     property D3DRMDevice2: IDirect3DRMDevice2 read FD3DRMDevice2;
  572.     property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
  573.     property Hardware: Boolean read GetHardware;
  574.     property Initialized: Boolean read FInitialized;
  575.     property NowOptions: TDX3DOptions read FNowOptions;
  576.     property OnFinalize: TNotifyEvent read FOnFinalize write FOnFinalize;
  577.     property OnInitialize: TNotifyEvent read FOnInitialize write FOnInitialize;
  578.     property Options: TDX3DOptions read FOptions write SetOptions;
  579.     property Scene: IDirect3DRMFrame read FScene;
  580.     property Surface: TDirectDrawSurface read FSurface;
  581.     property SurfaceHeight: Integer read GetSurfaceHeight write SetSurfaceHeight default 480;
  582.     property SurfaceWidth: Integer read GetSurfaceWidth write SetSurfaceWidth default 640;
  583.     property Viewport: IDirect3DRMViewport read FViewport;
  584.     property ZBuffer: TDirectDrawSurface read FZBuffer;
  585.   end;
  586.  
  587.   {  TDX3D  }
  588.  
  589.   TDX3D = class(TCustomDX3D)
  590.   published
  591.     property AutoSize;
  592.     property DXDraw;
  593.     property Options;
  594.     property SurfaceHeight;
  595.     property SurfaceWidth;
  596.     property OnFinalize;
  597.     property OnInitialize;
  598.   end;
  599.  
  600.   {  EDirect3DTextureError  }
  601.  
  602.   EDirect3DTextureError = class(Exception);
  603.  
  604.   {  TDirect3DTexture  }
  605.  
  606.   TDirect3DTexture = class
  607.   private
  608.     FBitCount: DWORD;
  609.     FDXDraw: TComponent;
  610.     FEnumFormatFlag: Boolean;
  611.     FFormat: DDSURFACEDESC;
  612.     FGraphic: TGraphic;
  613.     FHandle: D3DTEXTUREHANDLE;
  614.     FPaletteEntries: TPaletteEntries;
  615.     FSurface: TDirectDrawSurface;
  616.     FTexture: IDirect3DTexture;
  617.     FTransparentColor: TColor;
  618.     procedure Clear;
  619.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  620.     function GetHandle: D3DTEXTUREHANDLE;
  621.     function GetSurface: TDirectDrawSurface;
  622.     function GetTexture: IDirect3DTexture;
  623.     procedure SetTransparentColor(Value: TColor);
  624.   public
  625.     constructor Create(Graphic: TGraphic; DXDraw: TComponent);
  626.     destructor Destroy; override;
  627.     procedure Restore;
  628.     property Handle: D3DTEXTUREHANDLE read GetHandle;
  629.     property Surface: TDirectDrawSurface read GetSurface;
  630.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
  631.     property Texture: IDirect3DTexture read GetTexture;
  632.   end;
  633.  
  634.   {  EDirect3DRMUserVisualError  }
  635.  
  636.   EDirect3DRMUserVisualError = class(Exception);
  637.  
  638.   {  TDirect3DRMUserVisual  }
  639.  
  640.   TDirect3DRMUserVisual = class
  641.   private
  642.     FUserVisual: IDirect3DRMUserVisual;
  643.   protected
  644.     function DoRender(Reason: D3DRMUSERVISUALREASON;
  645.       D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT; virtual;
  646.   public
  647.     constructor Create(D3DRM: IDirect3DRM);
  648.     destructor Destroy; override;
  649.     property UserVisual: IDirect3DRMUserVisual read FUserVisual;
  650.   end;
  651.  
  652.   {  EPictureCollectionError  }
  653.  
  654.   EPictureCollectionError = class(Exception);
  655.  
  656.   {  TPictureCollectionItem  }
  657.  
  658.   TPictureCollection = class;
  659.  
  660.   TPictureCollectionItem = class(THashCollectionItem)
  661.   private
  662.     FPicture: TPicture;
  663.     FInitialized: Boolean;
  664.     FPatternHeight: Integer;
  665.     FPatternWidth: Integer;
  666.     FPatterns: TCollection;
  667.     FSkipHeight: Integer;
  668.     FSkipWidth: Integer;
  669.     FSurfaceList: TList;
  670.     FSystemMemory: Boolean;
  671.     FTransparent: Boolean;
  672.     FTransparentColor: TColor;
  673.     procedure ClearSurface;
  674.     procedure Finalize;
  675.     procedure Initialize;
  676.     function GetHeight: Integer;
  677.     function GetPictureCollection: TPictureCollection;
  678.     function GetPatternRect(Index: Integer): TRect;
  679.     function GetPatternSurface(Index: Integer): TDirectDrawSurface;
  680.     function GetPatternCount: Integer;
  681.     function GetWidth: Integer;
  682.     procedure SetPicture(Value: TPicture);
  683.     procedure SetTransparentColor(Value: TColor);
  684.   public                     
  685.     constructor Create(Collection: TCollection); override;
  686.     destructor Destroy; override;
  687.     procedure Draw(Dest: TDirectDrawSurface; X, Y, PatternIndex: Integer);
  688.     procedure StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
  689.     procedure DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  690.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  691.     procedure DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  692.       Alpha: Integer);
  693.     procedure DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  694.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  695.     procedure DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  696.       CenterX, CenterY: Double; Angle: Integer);
  697.     procedure DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  698.       CenterX, CenterY: Double; Angle: Integer;
  699.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  700.     procedure DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  701.       CenterX, CenterY: Double; Angle: Integer;
  702.       Alpha: Integer);
  703.     procedure DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  704.       CenterX, CenterY: Double; Angle: Integer;
  705.       Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  706.     procedure DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  707.       amp, Len, ph: Integer);
  708.     procedure DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  709.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  710.     procedure DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  711.       amp, Len, ph: Integer; Alpha: Integer);
  712.     procedure DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  713.       amp, Len, ph: Integer; Alpha: Integer{$IFDEF DelphiX_Delphi4}=255{$ENDIF});
  714.     procedure Restore;
  715.     property Height: Integer read GetHeight;
  716.     property Initialized: Boolean read FInitialized;
  717.     property PictureCollection: TPictureCollection read GetPictureCollection;
  718.     property PatternCount: Integer read GetPatternCount;
  719.     property PatternRects[Index: Integer]: TRect read GetPatternRect;
  720.     property PatternSurfaces[Index: Integer]: TDirectDrawSurface read GetPatternSurface;
  721.     property Width: Integer read GetWidth;
  722.   published
  723.     property PatternHeight: Integer read FPatternHeight write FPatternHeight;
  724.     property PatternWidth: Integer read FPatternWidth write FPatternWidth;
  725.     property Picture: TPicture read FPicture write SetPicture;
  726.     property SkipHeight: Integer read FSkipHeight write FSkipHeight default 0;
  727.     property SkipWidth: Integer read FSkipWidth write FSkipWidth default 0;
  728.     property SystemMemory: Boolean read FSystemMemory write FSystemMemory;
  729.     property Transparent: Boolean read FTransparent write FTransparent;
  730.     property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
  731.   end;
  732.  
  733.   {  TPictureCollection  }
  734.  
  735.   TPictureCollection = class(THashCollection)
  736.   private
  737.     FDXDraw: TCustomDXDraw;
  738.     FOwner: TPersistent;
  739.     function GetItem(Index: Integer): TPictureCollectionItem;
  740.     procedure ReadColorTable(Stream: TStream);
  741.     procedure WriteColorTable(Stream: TStream);
  742.     function Initialized: Boolean;
  743.   protected
  744.     procedure DefineProperties(Filer: TFiler); override;
  745.     function GetOwner: TPersistent; override;
  746.   public
  747.     ColorTable: TRGBQuads;
  748.     constructor Create(AOwner: TPersistent);
  749.     destructor Destroy; override;
  750.     function Find(const Name: string): TPictureCollectionItem;
  751.     procedure Finalize;
  752.     procedure Initialize(DXDraw: TCustomDXDraw);
  753.     procedure LoadFromFile(const FileName: string);
  754.     procedure LoadFromStream(Stream: TStream);
  755.     procedure MakeColorTable;
  756.     procedure Restore;
  757.     procedure SaveToFile(const FileName: string);
  758.     procedure SaveToStream(Stream: TStream);
  759.     property DXDraw: TCustomDXDraw read FDXDraw;
  760.     property Items[Index: Integer]: TPictureCollectionItem read GetItem; default;
  761.   end;
  762.  
  763.   {  TCustomDXImageList  }
  764.  
  765.   TCustomDXImageList = class(TComponent)
  766.   private
  767.     FDXDraw: TCustomDXDraw;
  768.     FItems: TPictureCollection;
  769.     procedure DXDrawNotifyEvent(Sender: TCustomDXDraw; NotifyType: TDXDrawNotifyType);
  770.     procedure SetDXDraw(Value: TCustomDXDraw);
  771.     procedure SetItems(Value: TPictureCollection);
  772.   protected
  773.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  774.   public
  775.     constructor Create(AOnwer: TComponent); override;
  776.     destructor Destroy; override;
  777.     property DXDraw: TCustomDXDraw read FDXDraw write SetDXDraw;
  778.     property Items: TPictureCollection read FItems write SetItems;
  779.   end;
  780.  
  781.   {  TDXImageList  }
  782.  
  783.   TDXImageList = class(TCustomDXImageList)
  784.   published
  785.     property DXDraw;
  786.     property Items;
  787.   end;
  788.  
  789. implementation
  790.  
  791. uses DXConsts, DXRender;
  792.  
  793. function DXDirectDrawEnumerate(lpCallback: LPDDENUMCALLBACKA;
  794.     lpContext: Pointer): HRESULT;
  795. type
  796.   TDirectDrawEnumerate = function(lpCallback: LPDDENUMCALLBACKA;
  797.     lpContext: Pointer): HRESULT; stdcall;
  798. begin
  799.   Result := TDirectDrawEnumerate(DXLoadLibrary('DDraw.dll', 'DirectDrawEnumerateA'))
  800.     (lpCallback, lpContext);
  801. end;
  802.  
  803. var
  804.   DirectDrawDrivers: TDirectXDrivers;
  805.  
  806. function EnumDirectDrawDrivers: TDirectXDrivers;
  807.  
  808.   function DDENUMCALLBACK(lpGuid: PGUID; lpstrDescription: LPCSTR;
  809.     lpstrModule: LPCSTR; lpContext: Pointer): BOOL; stdcall;
  810.   begin
  811.     Result := True;
  812.     with TDirectXDriver.Create(TDirectXDrivers(lpContext)) do
  813.     begin
  814.       Guid := lpGuid;
  815.       Description := lpstrDescription;
  816.       DriverName := lpstrModule;
  817.     end;
  818.   end;
  819.  
  820. begin
  821.   if DirectDrawDrivers=nil then
  822.   begin
  823.     DirectDrawDrivers := TDirectXDrivers.Create;
  824.     try
  825.       DXDirectDrawEnumerate(@DDENUMCALLBACK, DirectDrawDrivers);
  826.     except
  827.       DirectDrawDrivers.Free;
  828.       raise;
  829.     end;
  830.   end;
  831.  
  832.   Result := DirectDrawDrivers;
  833. end;
  834.  
  835.  
  836. function ClipRect(var DestRect: TRect; const DestRect2: TRect): Boolean;
  837. begin
  838.   with DestRect do
  839.   begin
  840.     Left := Max(Left, DestRect2.Left);
  841.     Right := Min(Right, DestRect2.Right);
  842.     Top := Max(Top, DestRect2.Top);
  843.     Bottom := Min(Bottom, DestRect2.Bottom);
  844.  
  845.     Result := (Left < Right) and (Top < Bottom);
  846.   end;
  847. end;
  848.  
  849. function ClipRect2(var DestRect, SrcRect: TRect; const DestRect2, SrcRect2: TRect): Boolean;
  850. begin
  851.   if DestRect.Left < DestRect2.Left then
  852.   begin
  853.     SrcRect.Left := SrcRect.Left + (DestRect2.Left - DestRect.Left);
  854.     DestRect.Left := DestRect2.Left;
  855.   end;
  856.  
  857.   if DestRect.Top < DestRect2.Top then
  858.   begin
  859.     SrcRect.Top := SrcRect.Top + (DestRect2.Top - DestRect.Top);
  860.     DestRect.Top := DestRect2.Top;
  861.   end;
  862.  
  863.   if SrcRect.Left < SrcRect2.Left then
  864.   begin
  865.     DestRect.Left := DestRect.Left + (SrcRect2.Left - SrcRect.Left);
  866.     SrcRect.Left := SrcRect2.Left;
  867.   end;
  868.  
  869.   if SrcRect.Top < SrcRect2.Top then
  870.   begin
  871.     DestRect.Top := DestRect.Top + (SrcRect2.Top - SrcRect.Top);
  872.     SrcRect.Top := SrcRect2.Top;
  873.   end;
  874.  
  875.   if DestRect.Right > DestRect2.Right then
  876.   begin
  877.     SrcRect.Right := SrcRect.Right - (DestRect.Right - DestRect2.Right);
  878.     DestRect.Right := DestRect2.Right;
  879.   end;
  880.  
  881.   if DestRect.Bottom > DestRect2.Bottom then
  882.   begin
  883.     SrcRect.Bottom := SrcRect.Bottom - (DestRect.Bottom - DestRect2.Bottom);
  884.     DestRect.Bottom := DestRect2.Bottom;
  885.   end;
  886.  
  887.   if SrcRect.Right > SrcRect2.Right then
  888.   begin
  889.     DestRect.Right := DestRect.Right - (SrcRect.Right - SrcRect2.Right);
  890.     SrcRect.Right := SrcRect2.Right;
  891.   end;
  892.  
  893.   if SrcRect.Bottom > SrcRect2.Bottom then
  894.   begin
  895.     DestRect.Bottom := DestRect.Bottom - (SrcRect.Bottom - SrcRect2.Bottom);
  896.     SrcRect.Bottom := SrcRect2.Bottom;
  897.   end;
  898.  
  899.   Result := (DestRect.Left < DestRect.Right) and
  900.             (DestRect.Top < DestRect.Bottom) and
  901.             (SrcRect.Left < SrcRect.Right) and
  902.             (SrcRect.Top < SrcRect.Bottom);
  903.  
  904. end;
  905.  
  906. {  TDirectDraw  }
  907.  
  908. constructor TDirectDraw.Create(GUID: PGUID);
  909. type
  910.   TDirectDrawCreate = function(lpGUID: PGUID; out lplpDD: IDirectDraw;
  911.     pUnkOuter: IUnknown): HRESULT; stdcall;
  912. var
  913.   DDraw: IDirectDraw;
  914. begin
  915.   if TDirectDrawCreate(DXLoadLibrary('DDraw.dll', 'DirectDrawCreate')) (GUID, DDraw, DDraw)=DD_OK then
  916.     CreateFromInterface(DDraw)
  917.   else
  918.     CreateFromInterface(nil);
  919. end;
  920.  
  921. constructor TDirectDraw.CreateFromInterface(DDraw: IDirectDraw);
  922. begin
  923.   inherited Create;
  924.   FClippers := TList.Create;
  925.   FPalettes := TList.Create;
  926.   FSurfaces := TList.Create;
  927.  
  928.   FIDDraw := DDraw;
  929.  
  930.   if FIDDraw=nil then
  931.     raise EDirectDrawError.CreateFmt(SCannotInitialized, [SDirectDraw]);
  932.  
  933.   try
  934.     FIDDraw4 := FIDDraw as IDirectDraw4;
  935.   except
  936.     raise EDirectDrawError.Create(SSinceDirectX6);
  937.   end;
  938.  
  939.   FDriverCaps.dwSize := SizeOf(FDriverCaps);
  940.   FHELCaps.dwSize := SizeOf(FHELCaps);
  941.   FIDDraw4.GetCaps(FDriverCaps, FHELCaps);
  942. end;
  943.  
  944. destructor TDirectDraw.Destroy;
  945. begin
  946.   while SurfaceCount>0 do
  947.     Surfaces[SurfaceCount-1].Free;
  948.  
  949.   while PaletteCount>0 do
  950.     Palettes[PaletteCount-1].Free;
  951.  
  952.   while ClipperCount>0 do
  953.     Clippers[ClipperCount-1].Free;
  954.  
  955.   FSurfaces.Free;
  956.   FPalettes.Free;
  957.   FClippers.Free;
  958.   inherited Destroy;
  959. end;
  960.  
  961. class function TDirectDraw.Drivers: TDirectXDrivers;
  962. begin
  963.   Result := EnumDirectDrawDrivers;
  964. end;
  965.  
  966. function TDirectDraw.GetClipper(Index: Integer): TDirectDrawClipper;
  967. begin
  968.   Result := FClippers[Index];
  969. end;
  970.  
  971. function TDirectDraw.GetClipperCount: Integer;
  972. begin
  973.   Result := FClippers.Count;
  974. end;
  975.  
  976. function TDirectDraw.GetDisplayMode: DDSURFACEDESC;
  977. begin
  978.   Result.dwSize := SizeOf(Result);
  979.   DXResult := IDraw.GetDisplayMode(Result);
  980.   if DXResult<>DD_OK then
  981.     FillChar(Result, SizeOf(Result), 0);
  982. end;
  983.  
  984. function TDirectDraw.GetIDDraw: IDirectDraw;
  985. begin
  986.   if Self<>nil then
  987.     Result := FIDDraw
  988.   else
  989.     Result := nil;
  990. end;
  991.  
  992. function TDirectDraw.GetIDDraw4: IDirectDraw4;
  993. begin
  994.   if Self<>nil then
  995.     Result := FIDDraw4
  996.   else
  997.     Result := nil;
  998. end;
  999.  
  1000. function TDirectDraw.GetIDraw: IDirectDraw;
  1001. begin
  1002.   Result := IDDraw;
  1003.   if Result=nil then
  1004.     raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw']);
  1005. end;
  1006.  
  1007. function TDirectDraw.GetIDraw4: IDirectDraw4;
  1008. begin
  1009.   Result := IDDraw4;
  1010.   if Result=nil then
  1011.     raise EDirectDrawError.CreateFmt(SNotMade, ['IDirectDraw4']);
  1012. end;
  1013.  
  1014. function TDirectDraw.GetPalette(Index: Integer): TDirectDrawPalette;
  1015. begin
  1016.   Result := FPalettes[Index];
  1017. end;
  1018.  
  1019. function TDirectDraw.GetPaletteCount: Integer;
  1020. begin
  1021.   Result := FPalettes.Count;
  1022. end;
  1023.  
  1024. function TDirectDraw.GetSurface(Index: Integer): TDirectDrawSurface;
  1025. begin
  1026.   Result := FSurfaces[Index];
  1027. end;
  1028.  
  1029. function TDirectDraw.GetSurfaceCount: Integer;
  1030. begin
  1031.   Result := FSurfaces.Count;
  1032. end;
  1033.  
  1034. {  TDirectDrawPalette  }
  1035.  
  1036. constructor TDirectDrawPalette.Create(ADirectDraw: TDirectDraw);
  1037. begin
  1038.   inherited Create;
  1039.   FDDraw := ADirectDraw;
  1040.   FDDraw.FPalettes.Add(Self);
  1041. end;
  1042.  
  1043. destructor TDirectDrawPalette.Destroy;
  1044. begin
  1045.   FDDraw.FPalettes.Remove(Self);
  1046.   inherited Destroy;
  1047. end;
  1048.  
  1049. function TDirectDrawPalette.CreatePalette(Caps: Integer;
  1050.   const Entries): Boolean;
  1051. var
  1052.   TempPalette: IDirectDrawPalette;
  1053. begin
  1054.   IDDPalette := nil;
  1055.  
  1056.   FDDraw.DXResult := FDDraw.IDraw.CreatePalette(Caps, @Entries, TempPalette, nil);
  1057.   FDXResult := FDDraw.DXResult;
  1058.   Result := FDDraw.DXResult=DD_OK;
  1059.   if Result then
  1060.     IDDPalette := TempPalette;
  1061. end;
  1062.  
  1063. procedure TDirectDrawPalette.LoadFromDIB(DIB: TDIB);
  1064. var
  1065.   Entries: TPaletteEntries;
  1066. begin
  1067.   Entries := RGBQuadsToPaletteEntries(DIB.ColorTable);
  1068.   CreatePalette(DDPCAPS_8BIT, Entries);
  1069. end;
  1070.  
  1071. procedure TDirectDrawPalette.LoadFromFile(const FileName: string);
  1072. var
  1073.   Stream: TFileStream;
  1074. begin
  1075.   Stream := TFileStream.Create(FileName, fmOpenRead);
  1076.   try
  1077.     LoadFromStream(Stream);
  1078.   finally
  1079.     Stream.Free;
  1080.   end;
  1081. end;
  1082.  
  1083. procedure TDirectDrawPalette.LoadFromStream(Stream: TStream);
  1084. var
  1085.   DIB: TDIB;
  1086. begin
  1087.   DIB := TDIB.Create;
  1088.   try
  1089.     DIB.LoadFromStream(Stream);
  1090.     if DIB.Size>0 then
  1091.       LoadFromDIB(DIB);
  1092.   finally
  1093.     DIB.Free;
  1094.   end;
  1095. end;
  1096.  
  1097. function TDirectDrawPalette.GetEntries(StartIndex, NumEntries: Integer;
  1098.   var Entries): Boolean;
  1099. begin
  1100.   if IDDPalette<>nil then
  1101.   begin
  1102.     DXResult := IPalette.GetEntries(0, StartIndex, NumEntries, @Entries);
  1103.     Result := DXResult=DD_OK;
  1104.   end else
  1105.     Result := False;
  1106. end;
  1107.  
  1108. function TDirectDrawPalette.GetEntry(Index: Integer): TPaletteEntry;
  1109. begin
  1110.   GetEntries(Index, 1, Result);
  1111. end;
  1112.  
  1113. function TDirectDrawPalette.GetIDDPalette: IDirectDrawPalette;
  1114. begin
  1115.   if Self<>nil then
  1116.     Result := FIDDPalette
  1117.   else
  1118.     Result := nil;
  1119. end;
  1120.  
  1121. function TDirectDrawPalette.GetIPalette: IDirectDrawPalette;
  1122. begin
  1123.   Result := IDDPalette;
  1124.   if Result=nil then
  1125.     raise EDirectDrawPaletteError.CreateFmt(SNotMade, ['IDirectDrawPalette']);
  1126. end;
  1127.  
  1128. function TDirectDrawPalette.SetEntries(StartIndex, NumEntries: Integer;
  1129.   const Entries): Boolean;
  1130. begin
  1131.   if IDDPalette<>nil then
  1132.   begin
  1133.     DXResult := IPalette.SetEntries(0, StartIndex, NumEntries, @Entries);
  1134.     Result := DXResult=DD_OK;
  1135.   end else
  1136.     Result := False;
  1137. end;
  1138.  
  1139. procedure TDirectDrawPalette.SetEntry(Index: Integer; Value: TPaletteEntry);
  1140. begin
  1141.   SetEntries(Index, 1, Value);
  1142. end;
  1143.  
  1144. procedure TDirectDrawPalette.SetIDDPalette(Value: IDirectDrawPalette);
  1145. begin
  1146.   FIDDPalette := Value;
  1147. end;
  1148.  
  1149. {  TDirectDrawClipper  }
  1150.  
  1151. constructor TDirectDrawClipper.Create(ADirectDraw: TDirectDraw);
  1152. begin
  1153.   inherited Create;
  1154.   FDDraw := ADirectDraw;
  1155.   FDDraw.FClippers.Add(Self);
  1156.  
  1157.   FDDraw.DXResult := FDDraw.IDraw.CreateClipper(0, FIDDClipper, nil);
  1158.   if FDDraw.DXResult<>DD_OK then
  1159.     raise EDirectDrawClipperError.CreateFmt(SCannotMade, [SDirectDrawClipper]);
  1160. end;
  1161.  
  1162. destructor TDirectDrawClipper.Destroy;
  1163. begin
  1164.   FDDraw.FClippers.Remove(Self);
  1165.   inherited Destroy;
  1166. end;
  1167.  
  1168. function TDirectDrawClipper.GetIDDClipper: IDirectDrawClipper;
  1169. begin
  1170.   if Self<>nil then
  1171.     Result := FIDDClipper
  1172.   else
  1173.     Result := nil;
  1174. end;
  1175.  
  1176. function TDirectDrawClipper.GetIClipper: IDirectDrawClipper;
  1177. begin
  1178.   Result := IDDClipper;
  1179.   if Result=nil then
  1180.     raise EDirectDrawClipperError.CreateFmt(SNotMade, ['IDirectDrawClipper']);
  1181. end;
  1182.  
  1183. procedure TDirectDrawClipper.SetClipRects(const Rects: array of TRect);
  1184. type
  1185.   PArrayRect = ^TArrayRect;
  1186.   TArrayRect = array[0..0] of TRect;
  1187. var
  1188.   RgnData: PRgnData;
  1189.   i: Integer;
  1190.   BoundsRect: TRect;
  1191. begin
  1192.   BoundsRect := Rect(MaxInt, MaxInt, -MaxInt, -MaxInt);
  1193.   for i:=Low(Rects) to High(Rects) do
  1194.   begin
  1195.     with BoundsRect do
  1196.     begin
  1197.       Left := Min(Rects[i].Left, Left);
  1198.       Right := Max(Rects[i].Left, Right);
  1199.       Top := Min(Rects[i].Left, Top);
  1200.       Bottom := Max(Rects[i].Left, Bottom);
  1201.     end;
  1202.   end;
  1203.  
  1204.   GetMem(RgnData, SizeOf(TRgnDataHeader)+SizeOf(TRect)*(High(Rects)-Low(Rects)+1));
  1205.   try
  1206.     with RgnData^.rdh do
  1207.     begin
  1208.       dwSize := SizeOf(TRgnDataHeader);
  1209.       iType := RDH_RECTANGLES;
  1210.       nCount := High(Rects)-Low(Rects)+1;
  1211.       nRgnSize := nCount*SizeOf(TRect);
  1212.       rcBound := BoundsRect;
  1213.     end;
  1214.     for i:=Low(Rects) to High(Rects) do
  1215.       PArrayRect(@RgnData^.Buffer)^[i-Low(Rects)] := Rects[i];
  1216.     DXResult := IClipper.SetClipList(RgnData, 0);
  1217.   finally
  1218.     FreeMem(RgnData);
  1219.   end;
  1220. end;
  1221.  
  1222. procedure TDirectDrawClipper.SetHandle(Value: THandle);
  1223. begin
  1224.   DXResult := IClipper.SetHWnd(0, Value);
  1225. end;
  1226.  
  1227. procedure TDirectDrawClipper.SetIDDClipper(Value: IDirectDrawClipper);
  1228. begin
  1229.   FIDDClipper := Value;
  1230. end;
  1231. {  TDirectDrawSurfaceCanvas  }
  1232.  
  1233. constructor TDirectDrawSurfaceCanvas.Create(ASurface: TDirectDrawSurface);
  1234. begin
  1235.   inherited Create;
  1236.   FSurface := ASurface;
  1237. end;
  1238.  
  1239. destructor TDirectDrawSurfaceCanvas.Destroy;
  1240. begin
  1241.   Release;
  1242.   FSurface.FCanvas := nil;
  1243.   inherited Destroy;
  1244. end;
  1245.  
  1246. procedure TDirectDrawSurfaceCanvas.CreateHandle;
  1247. begin
  1248.   FSurface.DXResult := FSurface.ISurface.GetDC(FDC);
  1249.   if FSurface.DXResult=DD_OK then
  1250.     Handle := FDC;
  1251. end;
  1252.  
  1253. procedure TDirectDrawSurfaceCanvas.Release;
  1254. begin
  1255.   if (FSurface.IDDSurface<>nil) and (FDC<>0) then
  1256.   begin
  1257.     Handle := 0;
  1258.     FSurface.IDDSurface.ReleaseDC(FDC);
  1259.     FDC := 0;
  1260.   end;
  1261. end;
  1262.  
  1263. {  TDirectDrawSurface  }
  1264.  
  1265. constructor TDirectDrawSurface.Create(ADirectDraw: TDirectDraw);
  1266. begin
  1267.   inherited Create;
  1268.   FDDraw := ADirectDraw;
  1269.   FDDraw.FSurfaces.Add(Self);
  1270. end;
  1271.  
  1272. destructor TDirectDrawSurface.Destroy;
  1273. begin
  1274.   FCanvas.Free;
  1275.   IDDSurface := nil;
  1276.   FDDraw.FSurfaces.Remove(Self);
  1277.   inherited Destroy;
  1278. end;
  1279.  
  1280. function TDirectDrawSurface.GetIDDSurface: IDirectDrawSurface;
  1281. begin
  1282.   if Self<>nil then
  1283.     Result := FIDDSurface
  1284.   else
  1285.     Result := nil;
  1286. end;
  1287.  
  1288. function TDirectDrawSurface.GetIDDSurface4: IDirectDrawSurface4;
  1289. begin
  1290.   if Self<>nil then
  1291.     Result := FIDDSurface4
  1292.   else
  1293.     Result := nil;
  1294. end;
  1295.  
  1296. function TDirectDrawSurface.GetISurface: IDirectDrawSurface;
  1297. begin                                  
  1298.   Result := IDDSurface;
  1299.   if Result=nil then
  1300.     raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface']);
  1301. end;
  1302.  
  1303. function TDirectDrawSurface.GetISurface4: IDirectDrawSurface4;
  1304. begin
  1305.   Result := IDDSurface4;
  1306.   if Result=nil then
  1307.     raise EDirectDrawSurfaceError.CreateFmt(SNotMade, ['IDirectDrawSurface4']);
  1308. end;
  1309.  
  1310. procedure TDirectDrawSurface.SetIDDSurface(Value: IDirectDrawSurface);
  1311. begin
  1312.   if Value=nil then
  1313.     SetIDDSurface4(nil)
  1314.   else
  1315.     SetIDDSurface4(Value as IDirectDrawSurface4);
  1316. end;
  1317.  
  1318. procedure TDirectDrawSurface.SetIDDSurface4(Value: IDirectDrawSurface4);
  1319. var
  1320.   Clipper: IDirectDrawClipper;
  1321. begin
  1322.   FIDDSurface4 := Value;
  1323.   FIDDSurface := Value as IDirectDrawSurface;
  1324.   FStretchDrawClipper := nil;
  1325.   FGammaControl := nil;
  1326.   FHasClipper := False;
  1327.   FillChar(FSurfaceDesc, SizeOf(FSurfaceDesc), 0);
  1328.  
  1329.   if FIDDSurface<>nil then
  1330.   begin
  1331.     FHasClipper := (FIDDSurface.GetClipper(Clipper)=DD_OK) and (Clipper<>nil);
  1332.  
  1333.     FSurfaceDesc.dwSize := SizeOf(FSurfaceDesc);
  1334.     FIDDSurface.GetSurfaceDesc(FSurfaceDesc);
  1335.  
  1336.     FIDDSurface.QueryInterface(IID_IDirectDrawGammaControl, FGammaControl);
  1337.   end;
  1338. end;
  1339.  
  1340. procedure TDirectDrawSurface.Assign(Source: TPersistent);
  1341. var
  1342.   TempSurface: IDirectDrawSurface;
  1343. begin
  1344.   if Source=nil then
  1345.     IDDSurface := nil
  1346.   else if Source is TGraphic then
  1347.     LoadFromGraphic(TGraphic(Source))
  1348.   else if Source is TPicture then
  1349.     LoadFromGraphic(TPicture(Source).Graphic)
  1350.   else if Source is TDirectDrawSurface then
  1351.   begin
  1352.     if TDirectDrawSurface(Source).IDDSurface=nil then
  1353.       IDDSurface := nil
  1354.     else begin
  1355.       FDDraw.DXResult := FDDraw.IDraw.DuplicateSurface(TDirectDrawSurface(Source).IDDSurface,
  1356.         TempSurface);
  1357.       if FDDraw.DXResult=0 then
  1358.       begin
  1359.         IDDSurface := TempSurface;
  1360.       end;
  1361.     end;
  1362.   end else
  1363.     inherited Assign(Source);
  1364. end;
  1365.  
  1366. procedure TDirectDrawSurface.AssignTo(Dest: TPersistent);
  1367. begin
  1368.   if Dest is TDIB then
  1369.   begin
  1370.     TDIB(Dest).SetSize(Width, Height, 24);
  1371.     TDIB(Dest).Canvas.CopyRect(Rect(0, 0, TDIB(Dest).Width, TDIB(Dest).Height), Canvas, ClientRect);
  1372.     Canvas.Release;
  1373.   end else
  1374.     inherited AssignTo(Dest);
  1375. end;
  1376.  
  1377. function TDirectDrawSurface.Blt(const DestRect, SrcRect: TRect; Flags: Integer;
  1378.   const DF: DDBLTFX; Source: TDirectDrawSurface): Boolean;
  1379. begin
  1380.   if IDDSurface<>nil then
  1381.   begin
  1382.     DXResult := ISurface.Blt(DestRect, Source.IDDSurface, SrcRect, DWORD(Flags), DF);
  1383.     Result := DXResult=DD_OK;
  1384.   end else
  1385.     Result := False;
  1386. end;
  1387.  
  1388. function TDirectDrawSurface.BltFast(X, Y: Integer; const SrcRect: TRect;
  1389.   Flags: Integer; Source: TDirectDrawSurface): Boolean;
  1390. begin
  1391.   if IDDSurface<>nil then
  1392.   begin
  1393.     DXResult := ISurface.BltFast(X, Y, Source.IDDSurface, SrcRect, DWORD(Flags));
  1394.     Result := DXResult=DD_OK;
  1395.   end else
  1396.     Result := False;
  1397. end;
  1398.  
  1399. function TDirectDrawSurface.ColorMatch(Col: TColor): Integer;
  1400. var
  1401.   DIB: TDIB;
  1402.   i, oldc: Integer;
  1403. begin
  1404.   if IDDSurface<>nil then
  1405.   begin
  1406.     oldc := Pixels[0, 0];
  1407.  
  1408.     DIB := TDIB.Create;
  1409.     try
  1410.       i := ColorToRGB(Col);
  1411.       DIB.SetSize(1, 1, 8);
  1412.       DIB.ColorTable[0] := RGBQuad(GetRValue(i), GetGValue(i), GetBValue(i));
  1413.       DIB.UpdatePalette;
  1414.       DIB.Pixels[0, 0] := 0;
  1415.  
  1416.       with Canvas do
  1417.       begin
  1418.         Draw(0, 0, DIB);
  1419.         Release;
  1420.       end;
  1421.     finally
  1422.       DIB.Free;
  1423.     end;
  1424.     Result := Pixels[0, 0];
  1425.     Pixels[0, 0] := oldc;
  1426.   end else
  1427.     Result := 0;
  1428. end;
  1429.  
  1430. function TDirectDrawSurface.CreateSurface(const SurfaceDesc: DDSURFACEDESC): Boolean;
  1431. var
  1432.   TempSurface: IDirectDrawSurface;
  1433. begin
  1434.   IDDSurface := nil;
  1435.  
  1436.   FDDraw.DXResult := FDDraw.IDraw.CreateSurface(SurfaceDesc, TempSurface, nil);
  1437.   FDXResult := FDDraw.DXResult;
  1438.   Result := FDDraw.DXResult=DD_OK;
  1439.   if Result then
  1440.   begin
  1441.     IDDSurface := TempSurface;
  1442.     TransparentColor := 0;
  1443.   end;
  1444. end;
  1445.  
  1446. {$IFDEF DelphiX_Delphi4}
  1447. function TDirectDrawSurface.CreateSurface(const SurfaceDesc: DDSURFACEDESC2): Boolean;
  1448. var
  1449.   TempSurface: IDirectDrawSurface4;
  1450. begin
  1451.   IDDSurface := nil;
  1452.  
  1453.   FDDraw.DXResult := FDDraw.IDraw4.CreateSurface(SurfaceDesc, TempSurface, nil);
  1454.   FDXResult := FDDraw.DXResult;
  1455.   Result := FDDraw.DXResult=DD_OK;
  1456.   if Result then
  1457.   begin
  1458.     IDDSurface4 := TempSurface;
  1459.     TransparentColor := 0;
  1460.   end;
  1461. end;
  1462. {$ENDIF}
  1463.  
  1464. procedure TDirectDrawSurface.Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface;
  1465.   Transparent: Boolean);
  1466. const
  1467.   BltFastFlags: array[Boolean] of Integer =
  1468.     (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
  1469.   BltFlags: array[Boolean] of Integer =
  1470.     (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  1471. var
  1472.   DestRect: TRect;
  1473.   DF: DDBLTFX;
  1474.   Clipper: IDirectDrawClipper;
  1475.   i: Integer;
  1476. begin
  1477.   if Source<>nil then
  1478.   begin
  1479.     if (X>Width) or (Y>Height) then Exit;
  1480.  
  1481.     if (SrcRect.Left>SrcRect.Right) or (SrcRect.Top>SrcRect.Bottom) then
  1482.     begin
  1483.       {  Mirror  }
  1484.       if ((X+Abs(SrcRect.Left-SrcRect.Right))<=0) or
  1485.         ((Y+Abs(SrcRect.Top-SrcRect.Bottom))<=0) then Exit;
  1486.  
  1487.       DF.dwsize := SizeOf(DF);
  1488.       DF.dwDDFX := 0;
  1489.  
  1490.       if SrcRect.Left>SrcRect.Right then
  1491.       begin
  1492.         i := SrcRect.Left; SrcRect.Left := SrcRect.Right; SrcRect.Right := i;
  1493.         DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORLEFTRIGHT;
  1494.       end;
  1495.                          
  1496.       if SrcRect.Top>SrcRect.Bottom then
  1497.       begin
  1498.         i := SrcRect.Top; SrcRect.Top := SrcRect.Bottom; SrcRect.Bottom := i;
  1499.         DF.dwDDFX := DF.dwDDFX or DDBLTFX_MIRRORUPDOWN;
  1500.       end;
  1501.  
  1502.       with SrcRect do                                     
  1503.         DestRect := Bounds(X, Y, Right-Left, Bottom-Top);
  1504.  
  1505.       if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
  1506.       begin
  1507.         if DF.dwDDFX and DDBLTFX_MIRRORLEFTRIGHT<>0 then
  1508.         begin
  1509.           i := SrcRect.Left;
  1510.           SrcRect.Left := Source.Width-SrcRect.Right;
  1511.           SrcRect.Right := Source.Width-i;
  1512.         end;
  1513.  
  1514.         if DF.dwDDFX and DDBLTFX_MIRRORUPDOWN<>0 then
  1515.         begin
  1516.           i := SrcRect.Top;
  1517.           SrcRect.Top := Source.Height-SrcRect.Bottom;
  1518.           SrcRect.Bottom := Source.Height-i;
  1519.         end;
  1520.                                                    
  1521.         Blt(DestRect, SrcRect, BltFlags[Transparent] or DDBLT_DDFX, df, Source);
  1522.       end;
  1523.     end else
  1524.     begin
  1525.       with SrcRect do
  1526.         DestRect := Bounds(X, Y, Right-Left, Bottom-Top);
  1527.  
  1528.       if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
  1529.       begin
  1530.         if FHasClipper then
  1531.         begin
  1532.           DF.dwsize := SizeOf(DF);
  1533.           DF.dwDDFX := 0;
  1534.           Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1535.         end else
  1536.         begin
  1537.           BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
  1538.           if DXResult=DDERR_BLTFASTCANTCLIP then
  1539.           begin
  1540.             ISurface.GetClipper(Clipper);
  1541.             if Clipper<>nil then FHasClipper := True;
  1542.  
  1543.             DF.dwsize := SizeOf(DF);
  1544.             DF.dwDDFX := 0;
  1545.             Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1546.           end;
  1547.         end;
  1548.       end;
  1549.     end;
  1550.   end;
  1551. end;
  1552.  
  1553. {$IFDEF DelphiX_Delphi4}
  1554. procedure TDirectDrawSurface.Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean);
  1555. const
  1556.   BltFastFlags: array[Boolean] of Integer =
  1557.     (DDBLTFAST_NOCOLORKEY or DDBLTFAST_WAIT, DDBLTFAST_SRCCOLORKEY or DDBLTFAST_WAIT);
  1558.   BltFlags: array[Boolean] of Integer =
  1559.     (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  1560. var
  1561.   DestRect, SrcRect: TRect;
  1562.   DF: DDBLTFX;
  1563.   Clipper: IDirectDrawClipper;
  1564. begin
  1565.   if Source<>nil then
  1566.   begin
  1567.     SrcRect := Source.ClientRect;
  1568.     DestRect := Bounds(X, Y, Source.Width, Source.Height);
  1569.  
  1570.     if ClipRect2(DestRect, SrcRect, ClientRect, Source.ClientRect) then
  1571.     begin
  1572.       if FHasClipper then
  1573.       begin
  1574.         DF.dwsize := SizeOf(DF);
  1575.         DF.dwDDFX := 0;
  1576.         Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1577.       end else
  1578.       begin
  1579.         BltFast(DestRect.Left, DestRect.Top, SrcRect, BltFastFlags[Transparent], Source);
  1580.         if DXResult=DDERR_BLTFASTCANTCLIP then
  1581.         begin
  1582.           ISurface.GetClipper(Clipper);
  1583.           if Clipper<>nil then FHasClipper := True;
  1584.  
  1585.           DF.dwsize := SizeOf(DF);
  1586.           DF.dwDDFX := 0;
  1587.           Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1588.         end;
  1589.       end;
  1590.     end;
  1591.   end;
  1592. end;
  1593. {$ENDIF}
  1594.  
  1595. procedure TDirectDrawSurface.StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  1596.   Transparent: Boolean);
  1597. const
  1598.   BltFlags: array[Boolean] of Integer =
  1599.     (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  1600. var
  1601.   DF: DDBLTFX;
  1602.   OldClipper: IDirectDrawClipper;
  1603.   Clipper: TDirectDrawClipper;
  1604. begin
  1605.   if Source<>nil then
  1606.   begin
  1607.     if (DestRect.Bottom<=DestRect.Top) or (DestRect.Right<=DestRect.Left) then Exit;
  1608.     if (SrcRect.Bottom<=SrcRect.Top) or (SrcRect.Right<=SrcRect.Left) then Exit;
  1609.  
  1610.     if FHasClipper then
  1611.     begin
  1612.       DF.dwsize := SizeOf(DF);
  1613.       DF.dwDDFX := 0;
  1614.       Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1615.     end else
  1616.     begin
  1617.       if FStretchDrawClipper=nil then
  1618.       begin
  1619.         Clipper := TDirectDrawClipper.Create(DDraw);
  1620.         try
  1621.           Clipper.SetClipRects([ClientRect]);
  1622.           FStretchDrawClipper := Clipper.IClipper;
  1623.         finally
  1624.           Clipper.Free;
  1625.         end;
  1626.       end;
  1627.  
  1628.       ISurface.GetClipper(OldClipper);
  1629.       ISurface.SetClipper(FStretchDrawClipper);
  1630.       DF.dwsize := SizeOf(DF);
  1631.       DF.dwDDFX := 0;
  1632.       Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1633.       ISurface.SetClipper(nil);
  1634.     end;
  1635.   end;
  1636. end;
  1637.  
  1638. {$IFDEF DelphiX_Delphi4}
  1639. procedure TDirectDrawSurface.StretchDraw(const DestRect: TRect; Source: TDirectDrawSurface;
  1640.   Transparent: Boolean);
  1641. const
  1642.   BltFlags: array[Boolean] of Integer =
  1643.  
  1644.     (DDBLT_WAIT, DDBLT_KEYSRC or DDBLT_WAIT);
  1645. var
  1646.   DF: DDBLTFX;
  1647.   OldClipper: IDirectDrawClipper;
  1648.   Clipper: TDirectDrawClipper;
  1649.   SrcRect: TRect;
  1650. begin                                                
  1651.   if Source<>nil then
  1652.   begin
  1653.     if (DestRect.Bottom<=DestRect.Top) or (DestRect.Right<=DestRect.Left) then Exit;
  1654.     SrcRect := Source.ClientRect;
  1655.  
  1656.     if ISurface.GetClipper(OldClipper)=DD_OK then
  1657.     begin
  1658.       DF.dwsize := SizeOf(DF);
  1659.       DF.dwDDFX := 0;
  1660.       Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1661.     end else
  1662.     begin
  1663.       if FStretchDrawClipper=nil then
  1664.       begin
  1665.         Clipper := TDirectDrawClipper.Create(DDraw);
  1666.         try
  1667.           Clipper.SetClipRects([ClientRect]);
  1668.           FStretchDrawClipper := Clipper.IClipper;
  1669.         finally
  1670.           Clipper.Free;
  1671.         end;
  1672.       end;
  1673.  
  1674.       ISurface.SetClipper(FStretchDrawClipper);
  1675.       try
  1676.         DF.dwsize := SizeOf(DF);
  1677.         DF.dwDDFX := 0;
  1678.         Blt(DestRect, SrcRect, BltFlags[Transparent], df, Source);
  1679.       finally
  1680.         ISurface.SetClipper(nil);
  1681.       end;
  1682.     end;
  1683.   end;
  1684.  end;
  1685. {$ENDIF}
  1686.  
  1687. procedure TDirectDrawSurface.DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  1688.   Transparent: Boolean; Alpha: Integer);
  1689. var
  1690.   Src_ddsd: DDSURFACEDESC;
  1691.   DestSurface, SrcSurface: TDXR_Surface;
  1692.   Blend: TDXR_Blend;
  1693. begin
  1694.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1695.   if (Width=0) or (Height=0) then Exit;
  1696.   if Source=nil then Exit;
  1697.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1698.  
  1699.   if Alpha<=0 then Exit;
  1700.  
  1701.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1702.   begin
  1703.     try
  1704.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1705.       begin
  1706.         try
  1707.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  1708.           begin
  1709.             Blend := DXR_BLEND_ONE1;
  1710.           end else
  1711.           if Alpha>=255 then
  1712.           begin
  1713.             Blend := DXR_BLEND_ONE1_ADD_ONE2;
  1714.           end else
  1715.           begin
  1716.             Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
  1717.           end;
  1718.  
  1719.           dxrCopyRectBlend(DestSurface, SrcSurface,
  1720.             DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1721.         finally
  1722.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1723.         end;
  1724.       end;
  1725.     finally
  1726.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1727.     end;
  1728.   end;
  1729. end;
  1730.  
  1731. procedure TDirectDrawSurface.DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  1732.   Transparent: Boolean; Alpha: Integer);
  1733. var
  1734.   Src_ddsd: DDSURFACEDESC;
  1735.   DestSurface, SrcSurface: TDXR_Surface;
  1736.   Blend: TDXR_Blend;
  1737. begin
  1738.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1739.   if (Width=0) or (Height=0) then Exit;
  1740.   if Source=nil then Exit;
  1741.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1742.  
  1743.   if Alpha<=0 then Exit;
  1744.  
  1745.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1746.   begin
  1747.     try
  1748.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1749.       begin
  1750.         try
  1751.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  1752.           begin
  1753.             Blend := DXR_BLEND_ONE1;
  1754.           end else
  1755.           if Alpha>=255 then
  1756.           begin
  1757.             Blend := DXR_BLEND_ONE1;
  1758.           end else
  1759.           begin
  1760.             Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
  1761.           end;
  1762.  
  1763.           dxrCopyRectBlend(DestSurface, SrcSurface,
  1764.             DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1765.         finally
  1766.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1767.         end;
  1768.       end;
  1769.     finally
  1770.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1771.     end;
  1772.   end;
  1773. end;
  1774.  
  1775. procedure TDirectDrawSurface.DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
  1776.   Transparent: Boolean; Alpha: Integer);
  1777. var
  1778.   Src_ddsd: DDSURFACEDESC;
  1779.   DestSurface, SrcSurface: TDXR_Surface;
  1780.   Blend: TDXR_Blend;
  1781. begin
  1782.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1783.   if (Width=0) or (Height=0) then Exit;
  1784.   if Source=nil then Exit;
  1785.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1786.  
  1787.   if Alpha<=0 then Exit;
  1788.  
  1789.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1790.   begin
  1791.     try
  1792.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1793.       begin
  1794.         try
  1795.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  1796.           begin
  1797.             Blend := DXR_BLEND_ONE1;
  1798.           end else
  1799.           if Alpha>=255 then
  1800.           begin
  1801.             Blend := DXR_BLEND_ONE2_SUB_ONE1;
  1802.           end else
  1803.           begin
  1804.             Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
  1805.           end;
  1806.  
  1807.           dxrCopyRectBlend(DestSurface, SrcSurface,
  1808.             DestRect, SrcRect, Blend, Alpha, Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1809.         finally
  1810.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1811.         end;
  1812.       end;
  1813.     finally
  1814.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1815.     end;
  1816.   end;
  1817. end;
  1818.  
  1819. procedure TDirectDrawSurface.DrawRotate(X, Y, Width, Height: Integer; SrcRect: TRect;
  1820.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer);
  1821. var
  1822.   Src_ddsd: DDSURFACEDESC;
  1823.   DestSurface, SrcSurface: TDXR_Surface;
  1824. begin
  1825.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1826.   if (Width=0) or (Height=0) then Exit;
  1827.   if Source=nil then Exit;
  1828.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1829.  
  1830.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1831.   begin
  1832.     try
  1833.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1834.       begin
  1835.         try
  1836.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  1837.             X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, DXR_BLEND_ONE1, 0,
  1838.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1839.         finally
  1840.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1841.         end;
  1842.       end;
  1843.     finally
  1844.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1845.     end;
  1846.   end;
  1847. end;
  1848.  
  1849. procedure TDirectDrawSurface.DrawRotateAdd(X, Y, Width, Height: Integer; SrcRect: TRect;
  1850.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle, Alpha: Integer);
  1851. var
  1852.   Src_ddsd: DDSURFACEDESC;
  1853.   DestSurface, SrcSurface: TDXR_Surface;
  1854.   Blend: TDXR_Blend;
  1855. begin
  1856.   if Alpha<=0 then Exit;
  1857.  
  1858.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1859.   if (Width=0) or (Height=0) then Exit;
  1860.   if Source=nil then Exit;
  1861.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1862.  
  1863.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1864.   begin
  1865.     try
  1866.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1867.       begin
  1868.         try
  1869.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  1870.           begin
  1871.             Blend := DXR_BLEND_ONE1;
  1872.           end else
  1873.           if Alpha>=255 then
  1874.           begin
  1875.             Blend := DXR_BLEND_ONE1_ADD_ONE2;
  1876.           end else
  1877.           begin
  1878.             Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
  1879.           end;
  1880.  
  1881.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  1882.             X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, Blend, Alpha,
  1883.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1884.         finally
  1885.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1886.         end;
  1887.       end;
  1888.     finally
  1889.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1890.     end;
  1891.   end;
  1892. end;
  1893.  
  1894. procedure TDirectDrawSurface.DrawRotateAlpha(X, Y, Width, Height: Integer; SrcRect: TRect;
  1895.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle, Alpha: Integer);
  1896. var
  1897.   Src_ddsd: DDSURFACEDESC;
  1898.   DestSurface, SrcSurface: TDXR_Surface;
  1899.   Blend: TDXR_Blend;
  1900. begin
  1901.   if Alpha<=0 then Exit;
  1902.  
  1903.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1904.   if (Width=0) or (Height=0) then Exit;
  1905.   if Source=nil then Exit;
  1906.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1907.  
  1908.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1909.   begin
  1910.     try
  1911.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1912.       begin
  1913.         try
  1914.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  1915.           begin
  1916.             Blend := DXR_BLEND_ONE1;
  1917.           end else
  1918.           if Alpha>=255 then
  1919.           begin
  1920.             Blend := DXR_BLEND_ONE1;
  1921.           end else
  1922.           begin
  1923.             Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
  1924.           end;
  1925.  
  1926.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  1927.             X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, Blend, Alpha,
  1928.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1929.         finally
  1930.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1931.         end;
  1932.       end;
  1933.     finally
  1934.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1935.     end;
  1936.   end;
  1937. end;
  1938.  
  1939. procedure TDirectDrawSurface.DrawRotateSub(X, Y, Width, Height: Integer; SrcRect: TRect;
  1940.   Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle, Alpha: Integer);
  1941. var
  1942.   Src_ddsd: DDSURFACEDESC;
  1943.   DestSurface, SrcSurface: TDXR_Surface;
  1944.   Blend: TDXR_Blend;
  1945. begin
  1946.   if Alpha<=0 then Exit;
  1947.  
  1948.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1949.   if (Width=0) or (Height=0) then Exit;
  1950.   if Source=nil then Exit;
  1951.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1952.  
  1953.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1954.   begin
  1955.     try
  1956.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1957.       begin
  1958.         try
  1959.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  1960.           begin
  1961.             Blend := DXR_BLEND_ONE1;
  1962.           end else
  1963.           if Alpha>=255 then
  1964.           begin
  1965.             Blend := DXR_BLEND_ONE2_SUB_ONE1;
  1966.           end else
  1967.           begin
  1968.             Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
  1969.           end;
  1970.  
  1971.           dxrDrawRotateBlend(DestSurface, SrcSurface,
  1972.             X, Y, Width, Height, SrcRect, CenterX, CenterY, Angle, Blend, Alpha,
  1973.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  1974.         finally
  1975.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  1976.         end;
  1977.       end;
  1978.     finally
  1979.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  1980.     end;
  1981.   end;
  1982. end;
  1983.  
  1984. procedure TDirectDrawSurface.DrawWaveX(X, Y, Width, Height: Integer; SrcRect: TRect;
  1985.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph: Integer);
  1986. var
  1987.   Src_ddsd: DDSURFACEDESC;
  1988.   DestSurface, SrcSurface: TDXR_Surface;
  1989. begin
  1990.   if (Self.Width=0) or (Self.Height=0) then Exit;
  1991.   if (Width=0) or (Height=0) then Exit;
  1992.   if Source=nil then Exit;
  1993.   if (Source.Width=0) or (Source.Height=0) then Exit;
  1994.  
  1995.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  1996.   begin
  1997.     try
  1998.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  1999.       begin
  2000.         try
  2001.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  2002.             X, Y, Width, Height, SrcRect, amp, Len, ph, DXR_BLEND_ONE1, 0,
  2003.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  2004.         finally
  2005.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  2006.         end;
  2007.       end;
  2008.     finally
  2009.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2010.     end;
  2011.   end;
  2012. end;
  2013.  
  2014. procedure TDirectDrawSurface.DrawWaveXAdd(X, Y, Width, Height: Integer; SrcRect: TRect;
  2015.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
  2016. var
  2017.   Src_ddsd: DDSURFACEDESC;
  2018.   DestSurface, SrcSurface: TDXR_Surface;
  2019.   Blend: TDXR_Blend;
  2020. begin
  2021.   if Alpha<=0 then Exit;
  2022.  
  2023.   if (Self.Width=0) or (Self.Height=0) then Exit;
  2024.   if (Width=0) or (Height=0) then Exit;
  2025.   if Source=nil then Exit;
  2026.   if (Source.Width=0) or (Source.Height=0) then Exit;
  2027.  
  2028.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  2029.   begin
  2030.     try
  2031.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  2032.       begin
  2033.         try
  2034.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  2035.           begin
  2036.             Blend := DXR_BLEND_ONE1;
  2037.           end else
  2038.           if Alpha>=255 then
  2039.           begin
  2040.             Blend := DXR_BLEND_ONE1_ADD_ONE2;
  2041.           end else
  2042.           begin
  2043.             Blend := DXR_BLEND_SRCALPHA1_ADD_ONE2;
  2044.           end;
  2045.  
  2046.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  2047.             X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
  2048.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  2049.         finally
  2050.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  2051.         end;
  2052.       end;
  2053.     finally
  2054.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2055.     end;
  2056.   end;
  2057. end;
  2058.  
  2059. procedure TDirectDrawSurface.DrawWaveXAlpha(X, Y, Width, Height: Integer; SrcRect: TRect;
  2060.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
  2061. var
  2062.   Src_ddsd: DDSURFACEDESC;
  2063.   DestSurface, SrcSurface: TDXR_Surface;
  2064.   Blend: TDXR_Blend;
  2065. begin
  2066.   if Alpha<=0 then Exit;
  2067.  
  2068.   if (Self.Width=0) or (Self.Height=0) then Exit;
  2069.   if (Width=0) or (Height=0) then Exit;
  2070.   if Source=nil then Exit;
  2071.   if (Source.Width=0) or (Source.Height=0) then Exit;
  2072.  
  2073.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  2074.   begin
  2075.     try
  2076.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  2077.       begin
  2078.         try
  2079.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  2080.           begin
  2081.             Blend := DXR_BLEND_ONE1;
  2082.           end else
  2083.           if Alpha>=255 then
  2084.           begin
  2085.             Blend := DXR_BLEND_ONE1;
  2086.           end else
  2087.           begin
  2088.             Blend := DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2;
  2089.           end;
  2090.  
  2091.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  2092.             X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
  2093.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  2094.         finally
  2095.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  2096.         end;
  2097.       end;
  2098.     finally
  2099.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2100.     end;
  2101.   end;
  2102. end;
  2103.  
  2104. procedure TDirectDrawSurface.DrawWaveXSub(X, Y, Width, Height: Integer; SrcRect: TRect;
  2105.   Source: TDirectDrawSurface; Transparent: Boolean; amp, Len, ph, Alpha: Integer);
  2106. var
  2107.   Src_ddsd: DDSURFACEDESC;
  2108.   DestSurface, SrcSurface: TDXR_Surface;
  2109.   Blend: TDXR_Blend;
  2110. begin
  2111.   if Alpha<=0 then Exit;
  2112.  
  2113.   if (Self.Width=0) or (Self.Height=0) then Exit;
  2114.   if (Width=0) or (Height=0) then Exit;
  2115.   if Source=nil then Exit;
  2116.   if (Source.Width=0) or (Source.Height=0) then Exit;
  2117.  
  2118.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  2119.   begin
  2120.     try
  2121.       if dxrDDSurfaceLock2(Source.ISurface, Src_ddsd, SrcSurface) then
  2122.       begin
  2123.         try
  2124.           if DestSurface.ColorType=DXR_COLORTYPE_INDEXED then
  2125.           begin
  2126.             Blend := DXR_BLEND_ONE1;
  2127.           end else
  2128.           if Alpha>=255 then
  2129.           begin    
  2130.             Blend := DXR_BLEND_ONE2_SUB_ONE1;
  2131.           end else
  2132.           begin
  2133.             Blend := DXR_BLEND_ONE2_SUB_SRCALPHA1;
  2134.           end;
  2135.  
  2136.           dxrDrawWaveXBlend(DestSurface, SrcSurface,
  2137.             X, Y, Width, Height, SrcRect, amp, Len, ph, Blend, Alpha,
  2138.             Transparent, Src_ddsd.ddckCKSrcBlt.dwColorSpaceLowValue);
  2139.         finally
  2140.           dxrDDSurfaceUnLock(Source.ISurface, SrcSurface)
  2141.         end;
  2142.       end;
  2143.     finally
  2144.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2145.     end;
  2146.   end;
  2147. end;
  2148.  
  2149. procedure TDirectDrawSurface.Fill(DevCol: Longint);
  2150. var
  2151.   DBltEx: DDBLTFX;
  2152. begin
  2153.   DBltEx.dwSize := SizeOf(DBltEx);
  2154.   DBltEx.dwFillColor := DevCol;
  2155.   Blt(TRect(nil^), TRect(nil^), DDBLT_COLORFILL or DDBLT_WAIT, DBltEx, nil);
  2156. end;
  2157.  
  2158. procedure TDirectDrawSurface.FillRect(const Rect: TRect; DevCol: Longint);
  2159. var
  2160.   DBltEx: DDBLTFX;
  2161.   DestRect: TRect;
  2162. begin
  2163.   DBltEx.dwSize := SizeOf(DBltEx);
  2164.   DBltEx.dwFillColor := DevCol;
  2165.   DestRect := Rect;
  2166.   if ClipRect(DestRect, ClientRect) then
  2167.     Blt(DestRect, TRect(nil^), DDBLT_COLORFILL or DDBLT_WAIT, DBltEx, nil);
  2168. end;
  2169.  
  2170. procedure TDirectDrawSurface.FillRectAdd(const DestRect: TRect; RGBCol: TColor);
  2171. var
  2172.   DestSurface: TDXR_Surface;
  2173. begin
  2174.   if RGBCol and $FFFFFF=0 then Exit;
  2175.   if (Self.Width=0) or (Self.Height=0) then Exit;
  2176.   if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  2177.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8)<>0 then Exit;
  2178.  
  2179.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  2180.   begin
  2181.     try
  2182.       dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE1_ADD_ONE2, ColorToRGB(RGBCol));
  2183.     finally
  2184.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2185.     end;
  2186.   end;
  2187. end;
  2188.                                           
  2189. procedure TDirectDrawSurface.FillRectAlpha(const DestRect: TRect; RGBCol: TColor;
  2190.   Alpha: Integer);
  2191. var
  2192.   DestSurface: TDXR_Surface;
  2193. begin
  2194.   if (Self.Width=0) or (Self.Height=0) then Exit;
  2195.   if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  2196.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8)<>0 then Exit;
  2197.  
  2198.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  2199.   begin
  2200.     try
  2201.       dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_SRCALPHA1_ADD_INVSRCALPHA2, ColorToRGB(RGBCol) or (Byte(Alpha) shl 24));
  2202.     finally
  2203.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2204.     end;
  2205.   end;
  2206. end;
  2207.  
  2208. procedure TDirectDrawSurface.FillRectSub(const DestRect: TRect; RGBCol: TColor);
  2209. var
  2210.   DestSurface: TDXR_Surface;
  2211. begin
  2212.   if RGBCol and $FFFFFF=0 then Exit;
  2213.   if (Self.Width=0) or (Self.Height=0) then Exit;
  2214.   if SurfaceDesc.ddpfPixelFormat.dwFlags and (DDPF_PALETTEINDEXED1 or DDPF_PALETTEINDEXED2 or
  2215.     DDPF_PALETTEINDEXED4 or DDPF_PALETTEINDEXED8)<>0 then Exit;
  2216.  
  2217.   if dxrDDSurfaceLock(ISurface, DestSurface) then
  2218.   begin
  2219.     try
  2220.       dxrFillRectColorBlend(DestSurface, DestRect, DXR_BLEND_ONE2_SUB_ONE1, ColorToRGB(RGBCol));
  2221.     finally
  2222.       dxrDDSurfaceUnLock(ISurface, DestSurface)
  2223.     end;
  2224.   end;
  2225. end;
  2226.  
  2227. function TDirectDrawSurface.GetBitCount: Integer;
  2228. begin
  2229.   Result := SurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  2230. end;
  2231.  
  2232. function TDirectDrawSurface.GetCanvas: TDirectDrawSurfaceCanvas;
  2233. begin
  2234.   if FCanvas=nil then
  2235.     FCanvas := TDirectDrawSurfaceCanvas.Create(Self);
  2236.   Result := FCanvas;
  2237. end;
  2238.  
  2239. function TDirectDrawSurface.GetClientRect: TRect;
  2240. begin
  2241.   Result := Rect(0, 0, Width, Height);
  2242. end;
  2243.  
  2244. function TDirectDrawSurface.GetHeight: Integer;
  2245. begin
  2246.   Result := SurfaceDesc.dwHeight;
  2247. end;
  2248.  
  2249. type
  2250.   PRGB = ^TRGB;
  2251.   TRGB = packed record
  2252.     R, G, B: Byte;
  2253.   end;
  2254.  
  2255. function TDirectDrawSurface.GetPixel(X, Y: Integer): Longint;
  2256. var
  2257.   ddsd: DDSURFACEDESC;
  2258. begin
  2259.   Result := 0;
  2260.   if (IDDSurface<>nil) and (X>=0) and (X<Width) and (Y>=0) and (Y<Height) then
  2261.   begin
  2262.     ddsd.dwSize := SizeOf(ddsd);
  2263.     if Lock(TRect(nil^), ddsd) then
  2264.     begin
  2265.       try
  2266.         case ddsd.ddpfPixelFormat.dwRGBBitCount of
  2267.           1 : Result := Integer(PByte(Integer(ddsd.lpSurface)+
  2268.                 Y*ddsd.lPitch+(X shr 3))^ and (1 shl (X and 7))<>0);
  2269.           4 : begin
  2270.                 if X and 1=0 then
  2271.                   Result := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 1))^ shr 4
  2272.                 else
  2273.                   Result := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 1))^ and $0F;
  2274.               end;
  2275.           8 : Result := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X)^;
  2276.           16: Result := PWord(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*2)^;
  2277.           24: with PRGB(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*3)^ do
  2278.                 Result := (R shl 16) or (G shl 8) or B;
  2279.           32: Result := PInteger(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*4)^;
  2280.         end;
  2281.       finally
  2282.         UnLock(ddsd.lpSurface);
  2283.       end;
  2284.     end;
  2285.   end;
  2286. end;
  2287.  
  2288. function TDirectDrawSurface.GetWidth: Integer;
  2289. begin
  2290.   Result := SurfaceDesc.dwWidth;
  2291. end;
  2292.  
  2293. procedure TDirectDrawSurface.LoadFromDIB(DIB: TDIB);
  2294. begin
  2295.   LoadFromGraphic(DIB);
  2296. end;
  2297.  
  2298. procedure TDirectDrawSurface.LoadFromDIBRect(DIB: TDIB; AWidth, AHeight: Integer; const SrcRect: TRect);
  2299. begin
  2300.   LoadFromGraphicRect(DIB, AWidth, AHeight, SrcRect);
  2301. end;
  2302.  
  2303. procedure TDirectDrawSurface.LoadFromGraphic(Graphic: TGraphic);
  2304. begin
  2305.   LoadFromGraphicRect(Graphic, 0, 0, Bounds(0, 0, Graphic.Width, Graphic.Height));
  2306. end;
  2307.  
  2308. procedure TDirectDrawSurface.LoadFromGraphicRect(Graphic: TGraphic; AWidth, AHeight: Integer; const SrcRect: TRect);
  2309. var
  2310.   Temp: TDIB;
  2311. begin
  2312.   if AWidth=0 then
  2313.     AWidth := SrcRect.Right-SrcRect.Left;
  2314.   if AHeight=0 then
  2315.     AHeight := SrcRect.Bottom-SrcRect.Top;
  2316.  
  2317.   SetSize(AWidth, AHeight);
  2318.  
  2319.   with SrcRect do
  2320.     if Graphic is TDIB then
  2321.     begin
  2322.       with Canvas do
  2323.       begin
  2324.         StretchBlt(Handle, 0, 0, AWidth, AHeight, TDIB(Graphic).Canvas.Handle,
  2325.           Left, Top, Right-Left, Bottom-Top,SRCCOPY);
  2326.         Release;
  2327.       end;
  2328.     end else if (Right-Left=AWidth) and (Bottom-Top=AHeight) then
  2329.     begin
  2330.       with Canvas do
  2331.       begin
  2332.         Draw(-Left, -Top, Graphic);
  2333.         Release;
  2334.       end;
  2335.     end else
  2336.     begin
  2337.       Temp := TDIB.Create;
  2338.       try
  2339.         Temp.SetSize(Right-Left, Bottom-Top, 24);
  2340.         Temp.Canvas.Draw(-Left, -Top, Graphic);
  2341.  
  2342.         with Canvas do
  2343.         begin
  2344.           StretchDraw(Bounds(0, 0, AWidth, AHeight), Temp);
  2345.           Release;
  2346.         end;
  2347.       finally
  2348.         Temp.Free;
  2349.       end;
  2350.     end;
  2351. end;
  2352.  
  2353. procedure TDirectDrawSurface.LoadFromFile(const FileName: string);
  2354. var
  2355.   Picture: TPicture;
  2356. begin
  2357.   Picture := TPicture.Create;
  2358.   try
  2359.     Picture.LoadFromFile(FileName);
  2360.     LoadFromGraphic(Picture.Graphic);
  2361.   finally
  2362.     Picture.Free;
  2363.   end;
  2364. end;
  2365.  
  2366. procedure TDirectDrawSurface.LoadFromStream(Stream: TStream);
  2367. var
  2368.   DIB: TDIB;
  2369. begin
  2370.   DIB := TDIB.Create;
  2371.   try
  2372.     DIB.LoadFromStream(Stream);
  2373.     if DIB.Size>0 then
  2374.       LoadFromGraphic(DIB);
  2375.   finally
  2376.     DIB.Free;
  2377.   end;
  2378. end;
  2379.  
  2380. function TDirectDrawSurface.Lock(const Rect: TRect; var SurfaceDesc: DDSURFACEDESC): Boolean;
  2381. begin
  2382.   if IDDSurface<>nil then
  2383.   begin
  2384.     DXResult := ISurface.Lock(@Rect, SurfaceDesc, DDLOCK_WAIT, 0);
  2385.     Result := DXResult=DD_OK;
  2386.   end else
  2387.     Result := False;
  2388. end;
  2389.  
  2390. {$IFDEF DelphiX_Delphi4}
  2391. function TDirectDrawSurface.Lock(var SurfaceDesc: DDSURFACEDESC): Boolean;
  2392. begin
  2393.   if IDDSurface<>nil then
  2394.   begin
  2395.     DXResult := ISurface.Lock(nil, SurfaceDesc, DDLOCK_WAIT, 0);
  2396.     Result := DXResult=DD_OK;
  2397.   end else
  2398.     Result := False;
  2399. end;
  2400. {$ENDIF}
  2401.  
  2402. procedure TDirectDrawSurface.UnLock(lpSurfaceData: Pointer);
  2403. begin
  2404.   if IDDSurface<>nil then
  2405.     DXResult := ISurface.UnLock(lpSurfaceData);
  2406. end;
  2407.  
  2408. function TDirectDrawSurface.Restore: Boolean;
  2409. begin
  2410.   if IDDSurface<>nil then
  2411.   begin
  2412.     DXResult := ISurface.Restore;
  2413.     Result := DXResult=DD_OK;
  2414.   end else
  2415.     Result := False;
  2416. end;
  2417.  
  2418. procedure TDirectDrawSurface.SetClipper(Value: TDirectDrawClipper);
  2419. begin
  2420.   if IDDSurface<>nil then
  2421.     DXResult := ISurface.SetClipper(Value.IDDClipper);
  2422.   FHasClipper := (Value<>nil) and (DXResult=DD_OK);
  2423. end;
  2424.  
  2425. procedure TDirectDrawSurface.SetColorKey(Flags: Integer; const Value: DDCOLORKEY);
  2426. begin
  2427.   if IDDSurface<>nil then
  2428.     DXResult := ISurface.SetColorKey(Flags, Value);
  2429. end;
  2430.  
  2431. procedure TDirectDrawSurface.SetPalette(Value: TDirectDrawPalette);
  2432. begin
  2433.   if IDDSurface<>nil then
  2434.     DXResult := ISurface.SetPalette(Value.IDDPalette);
  2435. end;
  2436.  
  2437. procedure TDirectDrawSurface.SetPixel(X, Y: Integer; Value: Longint);
  2438. var
  2439.   ddsd: DDSURFACEDESC;
  2440.   P: PByte;
  2441. begin
  2442.   if (IDDSurface<>nil) and (X>=0) and (X<Width) and (Y>=0) and (Y<Height) then
  2443.   begin
  2444.     ddsd.dwSize := SizeOf(ddsd);
  2445.     if Lock(TRect(nil^), ddsd) then
  2446.     begin
  2447.       try
  2448.         case ddsd.ddpfPixelFormat.dwRGBBitCount of
  2449.           1 : begin
  2450.                 P := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 3));
  2451.                 if Value=0 then
  2452.                   P^ := P^ and (not (1 shl (7-(X and 7))))
  2453.                 else
  2454.                   P^ := P^ or (1 shl (7-(X and 7)));
  2455.               end;
  2456.           4 : begin
  2457.                 P := PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+(X shr 1));
  2458.                 if X and 1=0 then
  2459.                   P^ := (P^ and $0F) or (Value shl 4)
  2460.                 else
  2461.                   P^ := (P^ and $F0) or (Value and $0F);
  2462.               end;
  2463.           8 : PByte(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X)^ := Value;
  2464.           16: PWord(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*2)^ := Value;
  2465.           24: with PRGB(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*3)^ do
  2466.               begin
  2467.                 R := Byte(Value shr 16);
  2468.                 G := Byte(Value shr 8);
  2469.                 B := Byte(Value);
  2470.               end;
  2471.           32: PInteger(Integer(ddsd.lpSurface)+Y*ddsd.lPitch+X*4)^ := Value;
  2472.         end;
  2473.       finally
  2474.         UnLock(ddsd.lpSurface);
  2475.       end;
  2476.     end;
  2477.   end;
  2478. end;
  2479.  
  2480. procedure TDirectDrawSurface.SetSize(AWidth, AHeight: Integer);
  2481. var
  2482.   ddsd: DDSURFACEDESC;
  2483. begin
  2484.   if (AWidth<=0) or (AHeight<=0) then
  2485.   begin
  2486.     IDDSurface := nil;
  2487.     Exit;
  2488.   end;
  2489.  
  2490.   with ddsd do
  2491.   begin
  2492.     dwSize := SizeOf(ddsd);
  2493.     dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT;
  2494.     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  2495.     if FSystemMemory then
  2496.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  2497.     dwHeight := AHeight;
  2498.     dwWidth := AWidth;
  2499.   end;
  2500.  
  2501.   if CreateSurface(ddsd) then Exit;
  2502.  
  2503.   {  When the Surface cannot be made,  making is attempted to the system memory.  }
  2504.   if ddsd.ddsCaps.dwCaps and DDSCAPS_SYSTEMMEMORY=0 then
  2505.   begin
  2506.     ddsd.ddsCaps.dwCaps := (ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY)) or DDSCAPS_SYSTEMMEMORY;
  2507.     if CreateSurface(ddsd) then
  2508.     begin
  2509.       FSystemMemory := True;
  2510.       Exit;
  2511.     end;
  2512.   end;
  2513.  
  2514.   raise EDirectDrawSurfaceError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  2515. end;
  2516.  
  2517. procedure TDirectDrawSurface.SetTransparentColor(Col: Longint);
  2518. var
  2519.   ddck: DDCOLORKEY;
  2520. begin
  2521.   ddck.dwColorSpaceLowValue := Col;
  2522.   ddck.dwColorSpaceHighValue := Col;
  2523.   ColorKey[DDCKEY_SRCBLT] := ddck;
  2524. end;
  2525.  
  2526. {  TDirectDrawDisplayMode  }
  2527.  
  2528. function TDirectDrawDisplayMode.GetBitCount: Integer;
  2529. begin
  2530.   Result := FSurfaceDesc.ddpfPixelFormat.dwRGBBitCount;
  2531. end;
  2532.  
  2533. function TDirectDrawDisplayMode.GetHeight: Integer;
  2534. begin
  2535.   Result := FSurfaceDesc.dwHeight;
  2536. end;
  2537.  
  2538. function TDirectDrawDisplayMode.GetWidth: Integer;
  2539. begin
  2540.   Result := FSurfaceDesc.dwWidth;
  2541. end;
  2542.  
  2543. {  TDirectDrawDisplay  }
  2544.  
  2545. constructor TDirectDrawDisplay.Create(ADXDraw: TCustomDXDraw);
  2546. begin
  2547.   inherited Create;
  2548.   FDXDraw := ADXDraw;
  2549.   FModes := TCollection.Create(TDirectDrawDisplayMode);
  2550.   FWidth := 640;
  2551.   FHeight := 480;
  2552.   FBitCount := 8;
  2553.   FFixedBitCount := True;
  2554.   FFixedRatio := True;
  2555.   FFixedSize := False;
  2556. end;
  2557.  
  2558. destructor TDirectDrawDisplay.Destroy;
  2559. begin
  2560.   FModes.Free;
  2561.   inherited Destroy;
  2562. end;
  2563.  
  2564. procedure TDirectDrawDisplay.Assign(Source: TPersistent);
  2565. begin
  2566.   if Source is TDirectDrawDisplay then
  2567.   begin
  2568.     if Source<>Self then
  2569.     begin
  2570.       FBitCount := TDirectDrawDisplay(Source).BitCount;
  2571.       FHeight := TDirectDrawDisplay(Source).Height;
  2572.       FWidth := TDirectDrawDisplay(Source).Width;
  2573.  
  2574.       FFixedBitCount := TDirectDrawDisplay(Source).FFixedBitCount;
  2575.       FFixedRatio := TDirectDrawDisplay(Source).FFixedRatio;
  2576.       FFixedSize := TDirectDrawDisplay(Source).FFixedSize;
  2577.     end;
  2578.   end else
  2579.     inherited Assign(Source);
  2580. end;
  2581.  
  2582. function TDirectDrawDisplay.GetCount: Integer;
  2583. begin
  2584.   if FModes.Count=0 then
  2585.     LoadDisplayModes;
  2586.   Result := FModes.Count;
  2587. end;
  2588.  
  2589. function TDirectDrawDisplay.GetMode: TDirectDrawDisplayMode;
  2590. var
  2591.   i: Integer;
  2592.   ddsd: DDSURFACEDESC;
  2593. begin
  2594.   Result := nil;
  2595.   if FDXDraw.DDraw<>nil then
  2596.   begin
  2597.     ddsd := FDXDraw.DDraw.DisplayMode;
  2598.     with ddsd do
  2599.       i := IndexOf(dwWidth, dwHeight, ddpfPixelFormat.dwRGBBitCount);
  2600.     if i<>-1 then
  2601.       Result := Modes[i];
  2602.   end;
  2603.   if Result=nil then
  2604.     raise EDirectDrawError.Create(SDisplayModeCannotAcquired);
  2605. end;
  2606.  
  2607. function TDirectDrawDisplay.GetMode2(Index: Integer): TDirectDrawDisplayMode;
  2608. begin
  2609.   if FModes.Count=0 then
  2610.     LoadDisplayModes;
  2611.   Result := TDirectDrawDisplayMode(FModes.Items[Index]);
  2612. end;
  2613.  
  2614. function TDirectDrawDisplay.IndexOf(Width, Height, BitCount: Integer): Integer;
  2615. var
  2616.   i: Integer;
  2617. begin
  2618.   Result := -1;
  2619.   for i:=0 to Count-1 do
  2620.     if (Modes[i].Width=Width) and (Modes[i].Height=Height) and (Modes[i].BitCount=BitCount) then
  2621.     begin
  2622.       Result := i;
  2623.       Exit;
  2624.     end;
  2625. end;
  2626.  
  2627. procedure TDirectDrawDisplay.LoadDisplayModes;
  2628.  
  2629.   function EnumDisplayModesProc(const lpDDSurfaceDesc: DDSURFACEDESC;
  2630.     lpContext: Pointer): HRESULT; stdcall;
  2631.   begin
  2632.     with TDirectDrawDisplayMode.Create(TCollection(lpContext)) do
  2633.       FSurfaceDesc := lpDDSurfaceDesc;
  2634.     Result := DDENUMRET_OK;
  2635.   end;
  2636.  
  2637. begin
  2638.   FModes.Clear;
  2639.   if FDXDraw.DDraw<>nil then
  2640.     FDXDraw.DDraw.DXResult := FDXDraw.DDraw.IDraw.EnumDisplayModes(0, LPDDSURFACEDESC(nil)^,
  2641.       FModes, @EnumDisplayModesProc);
  2642. end;
  2643.  
  2644. function TDirectDrawDisplay.SetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  2645. begin
  2646.   Result := False;
  2647.   if FDXDraw.DDraw<>nil then
  2648.   begin
  2649.     FDXDraw.DDraw.DXResult := FDXDraw.DDraw.IDraw.SetDisplayMode(AWidth, AHeight, ABitCount);
  2650.     Result := FDXDraw.DDraw.DXResult=DD_OK;
  2651.  
  2652.     if Result then
  2653.     begin
  2654.       FWidth := AWidth;
  2655.       FHeight := AHeight;
  2656.       FBitCount := ABitCount;
  2657.     end;
  2658.   end;
  2659. end;
  2660.  
  2661. function TDirectDrawDisplay.DynSetSize(AWidth, AHeight, ABitCount: Integer): Boolean;
  2662.  
  2663.   function TestBitCount(BitCount, ABitCount: Integer): Boolean;
  2664.   begin
  2665.     if (BitCount>8) and (ABitCount>8) then
  2666.     begin
  2667.       Result := True;
  2668.     end else
  2669.     begin
  2670.       Result := BitCount>=ABitCount;
  2671.     end;
  2672.   end;
  2673.  
  2674.   function SetSize2(Ratio: Boolean): Boolean;
  2675.   var
  2676.     DWidth, DHeight, DBitCount, i: Integer;
  2677.     Flag: Boolean;
  2678.   begin
  2679.     Result := False;
  2680.  
  2681.     DWidth := Maxint;
  2682.     DHeight := Maxint;
  2683.     DBitCount := ABitCount;
  2684.  
  2685.     Flag := False;
  2686.     for i:=0 to Count-1 do
  2687.       with Modes[i] do
  2688.       begin
  2689.         if ((DWidth>=Width) and (DHeight>=Width) and
  2690.           ((not Ratio) or (Width/Height=AWidth/AHeight)) and
  2691.           ((FFixedSize and (Width=AWidth) and (Height=Height)) or
  2692.           ((not FFixedSize) and (Width>=AWidth) and (Height>=AHeight))) and
  2693.  
  2694.           ((FFixedBitCount and (BitCount=ABitCount)) or
  2695.           ((not FFixedBitCount) and TestBitCount(BitCount, ABitCount)))) then
  2696.         begin
  2697.           DWidth := Width;
  2698.           DHeight := Height;
  2699.           DBitCount := BitCount;
  2700.           Flag := True;
  2701.         end;
  2702.       end;
  2703.  
  2704.     if Flag then
  2705.     begin
  2706.       if (DBitCount<>ABitCount) then
  2707.       begin
  2708.         if IndexOf(DWidth, DHEight, ABitCount)<>-1 then
  2709.           DBitCount := ABitCount;
  2710.       end;
  2711.  
  2712.       Result := SetSize(DWidth, DHeight, DBitCount);
  2713.     end;
  2714.   end;
  2715.  
  2716. begin
  2717.   Result := False;
  2718.  
  2719.   if (AWidth<=0) or (AHeight<=0) or (not (ABitCount in [8, 16, 24, 32])) then Exit;
  2720.  
  2721.   {  The change is attempted by the size of default.  }
  2722.   if SetSize(AWidth, AHeight, ABitCount) then
  2723.   begin
  2724.     Result := True;
  2725.     Exit;
  2726.   end;
  2727.  
  2728.   {  The change is attempted by the screen ratio fixation.  }
  2729.   if FFixedRatio then
  2730.     if SetSize2(True) then
  2731.     begin
  2732.       Result := True;
  2733.       Exit;
  2734.     end;
  2735.  
  2736.   {  The change is unconditionally attempted.  }
  2737.   if SetSize2(False) then
  2738.   begin
  2739.     Result := True;
  2740.     Exit;
  2741.   end;
  2742. end;
  2743.  
  2744. procedure TDirectDrawDisplay.SetBitCount(Value: Integer);
  2745. begin
  2746.   if not (Value in [8, 16, 24, 32]) then
  2747.     raise EDirectDrawError.Create(SInvalidDisplayBitCount);
  2748.   FBitCount := Value;
  2749. end;
  2750.  
  2751. procedure TDirectDrawDisplay.SetHeight(Value: Integer);
  2752. begin
  2753.   FHeight := Max(Value, 0);
  2754. end;
  2755.  
  2756. procedure TDirectDrawDisplay.SetWidth(Value: Integer);
  2757. begin
  2758.   FWidth := Max(Value, 0);
  2759. end;
  2760.  
  2761. {  TCustomDXDraw  }
  2762.  
  2763. function BPPToDDBD(BPP: DWORD): DWORD;
  2764. begin
  2765.   case BPP of
  2766.     1: Result := DDBD_1;
  2767.     2: Result := DDBD_2;
  2768.     4: Result := DDBD_4;
  2769.     8: Result := DDBD_8;
  2770.     16: Result := DDBD_16;
  2771.     24: Result := DDBD_24;
  2772.     32: Result := DDBD_32;
  2773.   else
  2774.     Result := 0;
  2775.   end;
  2776. end;
  2777.  
  2778. procedure FreeZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface);
  2779. begin
  2780.   if ZBuffer<>nil then
  2781.   begin
  2782.     if (Surface.IDDSurface<>nil) and (ZBuffer.IDDSurface<>nil) then
  2783.       Surface.ISurface.DeleteAttachedSurface(0, ZBuffer.IDDSurface);
  2784.     ZBuffer.Free; ZBuffer := nil;
  2785.   end;
  2786. end;
  2787.  
  2788. function CreateZBufferSurface(Surface: TDirectDrawSurface; var ZBuffer: TDirectDrawSurface;
  2789.   const DeviceDesc: D3DDeviceDesc; Hardware: Boolean): Boolean;
  2790. const
  2791.   MemPosition: array[Boolean] of Integer = (DDSCAPS_SYSTEMMEMORY, DDSCAPS_VIDEOMEMORY);
  2792. var
  2793.   ZBufferBitDepth: Integer;
  2794.   ddsd: DDSURFACEDESC;
  2795. begin
  2796.   Result := False;
  2797.   FreeZBufferSurface(Surface, ZBuffer);
  2798.  
  2799.   if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_16<>0 then
  2800.     ZBufferBitDepth := 16
  2801.   else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_24<>0 then
  2802.     ZBufferBitDepth := 24
  2803.   else if DeviceDesc.dwDeviceZBufferBitDepth and DDBD_32<>0 then
  2804.     ZBufferBitDepth := 32
  2805.   else
  2806.     ZBufferBitDepth := 0;
  2807.  
  2808.   if ZBufferBitDepth<>0 then
  2809.   begin
  2810.     with ddsd do
  2811.     begin
  2812.       dwSize := SizeOf(ddsd);
  2813.       Surface.ISurface.GetSurfaceDesc(ddsd);
  2814.       dwFlags := DDSD_CAPS or DDSD_WIDTH or DDSD_HEIGHT or DDSD_ZBUFFERBITDEPTH;
  2815.       ddsCaps.dwCaps := DDSCAPS_ZBUFFER or MemPosition[Hardware];
  2816.       dwHeight := Surface.Height;
  2817.       dwWidth := Surface.Width;
  2818.       dwZBufferBitDepth := ZBufferBitDepth;
  2819.     end;
  2820.  
  2821.     ZBuffer := TDirectDrawSurface.Create(Surface.DDraw);
  2822.     if ZBuffer.CreateSurface(ddsd) then
  2823.     begin
  2824.       if Surface.ISurface.AddAttachedSurface(ZBuffer.ISurface)<>DD_OK then
  2825.       begin
  2826.         ZBuffer.Free; ZBuffer := nil;
  2827.         Exit;
  2828.       end;
  2829.       Result := True;
  2830.     end else
  2831.     begin
  2832.       ZBuffer.Free; ZBuffer := nil;
  2833.       Exit;
  2834.     end;
  2835.   end;
  2836. end;
  2837.  
  2838. type
  2839.   TInitializeDirect3DOption = (idoSelectDriver, idoOptimizeDisplayMode,
  2840.     idoHardware, idoRetainedMode,
  2841.     idoZBuffer, idoRGB, idoMono, idoDither);
  2842.  
  2843.   TInitializeDirect3DOptions = set of TInitializeDirect3DOption;
  2844.  
  2845. procedure AdjustInitializeDirect3DOptions(var Options: TInitializeDirect3DOptions);
  2846. begin
  2847.   if Options*[idoRGB, idoMono]=[idoRGB, idoMono] then
  2848.     Options := (Options - [idoRGB, idoMono]) + [idoRGB];
  2849.   if Options*[idoRGB, idoMono]=[] then
  2850.     Options := Options + [idoRGB];
  2851. end;
  2852.  
  2853. procedure Direct3DInitializing(Options: TInitializeDirect3DOptions;
  2854.   var BitCount: Integer; var Driver: PGUID; var DriverGUID: TGUID);
  2855. type
  2856.   TDirect3DInitializingRecord = record
  2857.     Options: TInitializeDirect3DOptions;
  2858.     Driver: ^PGUID;
  2859.     DriverGUID: PGUID;
  2860.     BitCount: Integer;
  2861.  
  2862.     Flag: Boolean;
  2863.     DriverCaps, HELCaps: DDCAPS;
  2864.     HWDeviceDesc, HELDeviceDesc, DeviceDesc: D3DDEVICEDESC;
  2865.  
  2866.     D3DFlag: Boolean;
  2867.     HWDeviceDesc2, HELDeviceDesc2, DeviceDesc2: D3DDEVICEDESC;
  2868.   end;
  2869.  
  2870.   function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
  2871.     const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: D3DDeviceDesc;
  2872.     lpUserArg: Pointer): HRESULT; stdcall;
  2873.   var
  2874.     dev: ^D3DDEVICEDESC;
  2875.     rec: ^TDirect3DInitializingRecord;
  2876.  
  2877.     procedure UseThisDevice;
  2878.     begin
  2879.       rec.D3DFlag := True;
  2880.       rec.HWDeviceDesc2 := lpD3DHWDeviceDesc;
  2881.       rec.HELDeviceDesc2 := lpD3DHELDeviceDesc;
  2882.       rec.DeviceDesc2 := dev^;
  2883.     end;
  2884.  
  2885.   begin
  2886.     Result := D3DENUMRET_OK;
  2887.     rec := lpUserArg;
  2888.  
  2889.     if lpD3DHWDeviceDesc.dcmColorModel=D3DCOLOR_INVALID_0 then Exit;
  2890.  
  2891.     dev := @lpD3DHWDeviceDesc;
  2892.  
  2893.     {  Bit depth test.  }
  2894.     if idoOptimizeDisplayMode in rec.Options then
  2895.     begin
  2896.       if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and (DDBD_16 or DDBD_24 or DDBD_32))=0 then Exit;
  2897.     end else
  2898.     begin
  2899.       if (lpD3DHWDeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then Exit;
  2900.     end;
  2901.  
  2902.     UseThisDevice;
  2903.   end;
  2904.  
  2905.   function EnumDirectDrawDriverCallback(lpGUID: PGUID; lpDriverDescription: LPSTR;
  2906.     lpDriverName: LPSTR; lpContext: Pointer): HRESULT; stdcall;
  2907.   var
  2908.     DDraw: TDirectDraw;
  2909.     Direct3D: IDirect3D;
  2910.     rec: ^TDirect3DInitializingRecord;
  2911.  
  2912.     function CountBitMask(i: DWORD; const Bits: array of DWORD): DWORD;
  2913.     var
  2914.       j: Integer;
  2915.     begin
  2916.       Result := 0;
  2917.  
  2918.       for j:=Low(Bits) to High(Bits) do
  2919.       begin
  2920.         if i and Bits[j]<>0 then
  2921.           Inc(Result);
  2922.       end;
  2923.     end;
  2924.  
  2925.     function CompareCountBitMask(i, i2: DWORD; const Bits: array of DWORD): Integer;
  2926.     var
  2927.       j, j2: DWORD;
  2928.     begin
  2929.       j := CountBitMask(i, Bits);
  2930.       j2 := CountBitMask(i2, Bits);
  2931.  
  2932.       if j<j2 then
  2933.         Result := -1
  2934.       else if i>j2 then
  2935.         Result := 1
  2936.       else
  2937.         Result := 0;
  2938.     end;
  2939.  
  2940.     function CountBit(i: DWORD): DWORD;
  2941.     var
  2942.       j: Integer;
  2943.     begin
  2944.       Result := 0;     
  2945.  
  2946.       for j:=0 to 31 do
  2947.         if i and (1 shl j)<>0 then
  2948.           Inc(Result);
  2949.     end;
  2950.  
  2951.     function CompareCountBit(i, i2: DWORD): Integer;
  2952.     var
  2953.       j, j2: DWORD;
  2954.     begin
  2955.       j := CountBit(i);
  2956.       j2 := CountBit(i2);
  2957.  
  2958.       if j<j2 then
  2959.         Result := -1
  2960.       else if i>j2 then
  2961.         Result := 1
  2962.       else
  2963.         Result := 0;
  2964.     end;
  2965.  
  2966.     function FindDevice: Boolean;
  2967.     begin
  2968.       {  The Direct3D driver is examined.  }
  2969.       rec.D3DFlag := False;
  2970.       Direct3D.EnumDevices(@EnumDeviceCallBack, lpContext);
  2971.       Result := rec.D3DFlag;
  2972.  
  2973.       if not Result then Exit;
  2974.  
  2975.       {  Comparison of DirectDraw driver.  }
  2976.       if not rec.Flag then
  2977.       begin
  2978.         rec.HWDeviceDesc := rec.HWDeviceDesc2;
  2979.         rec.HELDeviceDesc := rec.HELDeviceDesc2;
  2980.         rec.DeviceDesc := rec.DeviceDesc2;
  2981.         rec.Flag := True;
  2982.       end else
  2983.       begin
  2984.         {  Comparison of hardware. (One with large number of functions to support is chosen.  }
  2985.         Result := False;
  2986.  
  2987.         if DDraw.DriverCaps.dwVidMemTotal<rec.DriverCaps.dwVidMemTotal then Exit;
  2988.  
  2989.         if CompareCountBitMask(DDraw.DriverCaps.ddscaps.dwCaps, rec.DriverCaps.ddscaps.dwCaps, [DDSCAPS_TEXTURE, DDSCAPS_ZBUFFER, DDSCAPS_MIPMAP])+
  2990.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwMiscCaps, rec.HWDeviceDesc2.dpcLineCaps.dwMiscCaps)+
  2991.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwRasterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwRasterCaps)+
  2992.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwAlphaCmpCaps, rec.HWDeviceDesc2.dpcLineCaps.dwAlphaCmpCaps)+
  2993.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwSrcBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwSrcBlendCaps)+
  2994.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwDestBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwDestBlendCaps)+
  2995.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwShadeCaps, rec.HWDeviceDesc2.dpcLineCaps.dwShadeCaps)+
  2996.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureCaps)+
  2997.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureFilterCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureFilterCaps)+
  2998.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureBlendCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureBlendCaps)+
  2999.           CompareCountBit(rec.HWDeviceDesc.dpcLineCaps.dwTextureAddressCaps, rec.HWDeviceDesc2.dpcLineCaps.dwTextureAddressCaps)<0 then Exit;
  3000.  
  3001.         Result := True;
  3002.       end;
  3003.     end;
  3004.  
  3005.     function CompareGUID(guid1, guid2: PGUID): Boolean;
  3006.     begin
  3007.       if (Integer(guid1) in [0, DDCREATE_HARDWAREONLY, DDCREATE_EMULATIONONLY]) or
  3008.         (Integer(guid2) in [0, DDCREATE_HARDWAREONLY, DDCREATE_EMULATIONONLY]) then
  3009.         Result := guid1=guid2
  3010.       else
  3011.         Result := CompareMem(guid1, guid2, SizeOf(TGUID));
  3012.     end;
  3013.  
  3014.   begin
  3015.     Result := DDENUMRET_OK;
  3016.     rec := lpContext;
  3017.  
  3018.     DDraw := TDirectDraw.Create(lpGUID);
  3019.     try
  3020.       if (DDraw.DriverCaps.dwCaps and DDCAPS_3D<>0) and
  3021.         (DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE<>0) then
  3022.       begin
  3023.         Direct3D := DDraw.IDraw as IDirect3D;
  3024.         try
  3025.           if FindDevice then
  3026.           begin
  3027.             rec.DriverCaps := DDraw.DriverCaps;
  3028.             rec.HELCaps := DDraw.HELCaps;
  3029.  
  3030.             if lpGUID=nil then
  3031.               rec.Driver := nil
  3032.             else begin
  3033.               rec.DriverGUID^ := lpGUID^;
  3034.               rec.Driver^ := @rec.DriverGUID;
  3035.             end;
  3036.           end;
  3037.         finally
  3038.           Direct3D := nil;
  3039.         end;
  3040.       end;
  3041.     finally
  3042.       DDraw.Free;
  3043.     end;
  3044.   end;
  3045.  
  3046. var
  3047.   rec: TDirect3DInitializingRecord;
  3048.   DDraw: TDirectDraw;
  3049. begin
  3050.   AdjustInitializeDirect3DOptions(Options);
  3051.  
  3052.   FillChar(rec, SizeOf(rec), 0);
  3053.   rec.BitCount := BitCount;
  3054.  
  3055.   {  Driver selection   }   
  3056.   if idoSelectDriver in rec.Options then
  3057.   begin
  3058.     rec.Flag := False;
  3059.     rec.Options := Options;
  3060.     rec.Driver := @Driver;
  3061.     rec.DriverGUID := @DriverGUID;
  3062.     DXDirectDrawEnumerate(@EnumDirectDrawDriverCallback, @rec)
  3063.   end else                                     
  3064.   begin
  3065.     DDraw := TDirectDraw.Create(Driver);
  3066.     try
  3067.       rec.DriverCaps := DDraw.DriverCaps;
  3068.       rec.HELCaps := DDraw.HELCaps;
  3069.     finally
  3070.       DDraw.Free;
  3071.     end;
  3072.     rec.Flag := True;
  3073.   end;
  3074.  
  3075.   {  Display mode optimization  }
  3076.   if rec.Flag and (idoOptimizeDisplayMode in Options) then
  3077.   begin
  3078.     if (rec.DeviceDesc.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then
  3079.     begin   
  3080.       if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_16<>0 then
  3081.         rec.BitCount := 16
  3082.       else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_24<>0 then
  3083.         rec.BitCount := 24
  3084.       else if rec.DeviceDesc.dwDeviceRenderBitDepth and DDBD_32<>0 then
  3085.         rec.BitCount := 32;
  3086.     end;
  3087.   end;
  3088.  
  3089.   BitCount := rec.BitCount;
  3090. end;
  3091.  
  3092. procedure Direct3DInitializing_DXDraw(Options: TInitializeDirect3DOptions;
  3093.   DXDraw: TCustomDXDraw);
  3094. var
  3095.   BitCount: Integer;
  3096.   Driver: PGUID;
  3097.   DriverGUID: TGUID;
  3098. begin
  3099.   BitCount := DXDraw.Display.BitCount;
  3100.   Driver := DXDraw.Driver;
  3101.   Direct3DInitializing(Options, BitCount, Driver, DriverGUID);
  3102.   DXDraw.Driver := Driver;
  3103.   DXDraw.Display.BitCount := BitCount;
  3104. end;
  3105.  
  3106. procedure InitializeDirect3D(Surface: TDirectDrawSurface;
  3107.   var ZBuffer: TDirectDrawSurface;
  3108.   out D3D: IDirect3D;
  3109.   out D3D2: IDirect3D2;
  3110.   out D3D3: IDirect3D3;
  3111.   out D3DDevice: IDirect3DDevice;
  3112.   out D3DDevice2: IDirect3DDevice2;
  3113.   out D3DDevice3: IDirect3DDevice3;
  3114.   var D3DRM: IDirect3DRM;
  3115.   var D3DRM2: IDirect3DRM2;
  3116.   out D3DRMDevice: IDirect3DRMDevice;
  3117.   out D3DRMDevice2: IDirect3DRMDevice2;
  3118.   out Viewport: IDirect3DRMViewport;
  3119.   var Scene: IDirect3DRMFrame;
  3120.   var Camera: IDirect3DRMFrame;
  3121.   var HWDeviceDesc, HELDeviceDesc, DeviceDesc: D3DDEVICEDESC;
  3122.   var NowOptions: TInitializeDirect3DOptions);
  3123. type
  3124.   TInitializeDirect3DRecord = record
  3125.     Flag: Boolean;
  3126.     BitCount: Integer;
  3127.     HWDeviceDesc, HELDeviceDesc, DeviceDesc: ^D3DDEVICEDESC;
  3128.     Hardware: Boolean;
  3129.     Options: TInitializeDirect3DOptions;
  3130.     GUID: TGUID;
  3131.     SupportHardware: Boolean;
  3132.   end;
  3133.  
  3134.   function EnumDeviceCallBack(const lpGuid: TGUID; lpDeviceDescription, lpDeviceName: PChar;
  3135.     const lpD3DHWDeviceDesc, lpD3DHELDeviceDesc: D3DDeviceDesc;
  3136.     lpUserArg: Pointer): HRESULT; stdcall;
  3137.   var
  3138.     dev: ^D3DDeviceDesc;
  3139.     Hardware: Boolean;
  3140.     rec: ^TInitializeDirect3DRecord;
  3141.  
  3142.     procedure UseThisDevice;
  3143.     begin
  3144.       rec.Flag := True;
  3145.       rec.GUID := lpGUID;
  3146.       rec.HWDeviceDesc^ := lpD3DHWDeviceDesc;
  3147.       rec.HELDeviceDesc^ := lpD3DHELDeviceDesc;
  3148.       rec.DeviceDesc^ := dev^;
  3149.       rec.Hardware := Hardware;
  3150.     end;
  3151.  
  3152.   var
  3153.     PriorityColorModel: DWORD;
  3154.   begin
  3155.     Result := D3DENUMRET_OK;
  3156.     rec := lpUserArg;
  3157.  
  3158.     Hardware := lpD3DHWDeviceDesc.dcmColorModel<>D3DCOLOR_INVALID_0;
  3159.     if Hardware then           
  3160.       dev := @lpD3DHWDeviceDesc
  3161.     else
  3162.       dev := @lpD3DHELDeviceDesc;
  3163.  
  3164.     if (Hardware) and (not rec.SupportHardware) then Exit;
  3165.  
  3166.     {  Bit depth test.  }
  3167.     if (dev.dwDeviceRenderBitDepth and BPPToDDBD(rec.BitCount))=0 then Exit;
  3168.  
  3169.     {  Color model test. (Gives priority RGB when there is hardware.)  }
  3170.     PriorityColorModel := 0;
  3171.     if idoRGB in rec.Options then
  3172.       PriorityColorModel := D3DCOLOR_RGB;
  3173.     if idoMono in rec.Options then
  3174.       PriorityColorModel := D3DCOLOR_MONO;
  3175.  
  3176.     if rec.Flag and (not Hardware) and (rec.DeviceDesc.dcmColorModel=PriorityColorModel) and
  3177.       (dev.dcmColorModel<>PriorityColorModel) then Exit;
  3178.  
  3179.     if Hardware then
  3180.     begin
  3181.       {  Hardware  }
  3182.       UseThisDevice;
  3183.     end else
  3184.     begin
  3185.       {  Software  }
  3186.       if not rec.Hardware then
  3187.         UseThisDevice;
  3188.     end;
  3189.   end;
  3190.  
  3191. var
  3192.   Hardware: Boolean;
  3193.   SupportHardware: Boolean;
  3194.   D3DDeviceGUID: TGUID;
  3195.   Options: TInitializeDirect3DOptions;
  3196.  
  3197.   procedure InitDevice;
  3198.   var
  3199.     rec: TInitializeDirect3DRecord;
  3200.   begin
  3201.     {  Device search  }
  3202.     rec.Flag := False;
  3203.     rec.BitCount := Surface.BitCount;
  3204.     rec.HWDeviceDesc := @HWDeviceDesc;
  3205.     rec.HELDeviceDesc := @HELDeviceDesc;
  3206.     rec.Hardware := False;
  3207.     rec.DeviceDesc := @DeviceDesc;
  3208.     rec.Options := Options;
  3209.     rec.SupportHardware := SupportHardware;
  3210.  
  3211.     D3D3.EnumDevices(@EnumDeviceCallBack, @rec);
  3212.     if not rec.Flag then
  3213.       raise EDXDrawError.Create(S3DDeviceNotFound);
  3214.  
  3215.     Hardware := rec.Hardware;
  3216.     D3DDeviceGUID := rec.GUID;
  3217.  
  3218.     if Hardware then
  3219.       NowOptions := NowOptions + [idoHardware];
  3220.  
  3221.     NowOptions := NowOptions - [idoRGB, idoMono];
  3222.     if DeviceDesc.dcmColorModel=D3DCOLOR_RGB then
  3223.       NowOptions := NowOptions + [idoRGB]
  3224.     else if DeviceDesc.dcmColorModel=D3DCOLOR_MONO then
  3225.       NowOptions := NowOptions + [idoMono];
  3226.  
  3227.     {  Z buffer making  }
  3228.     NowOptions := NowOptions - [idoZBuffer];
  3229.     if idoZBuffer in Options then
  3230.     begin
  3231.       if CreateZBufferSurface(Surface, ZBuffer, DeviceDesc, Hardware) then
  3232.         NowOptions := NowOptions + [idoZBuffer];
  3233.     end;
  3234.   end;
  3235.  
  3236. type
  3237.   TDirect3DRMCreate= function(out lplpDirect3DRM: IDirect3DRM): HRESULT; stdcall;
  3238. begin
  3239.   try
  3240.     Options := NowOptions;
  3241.     NowOptions := [];
  3242.  
  3243.     AdjustInitializeDirect3DOptions(Options);
  3244.  
  3245.     D3D3 := Surface.DDraw.IDraw4 as IDirect3D3;
  3246.     D3D2 := D3D3 as IDirect3D2;
  3247.     D3D := D3D3 as IDirect3D;
  3248.  
  3249.     {  Whether hardware can be used is tested.  }
  3250.     SupportHardware := (Surface.SurfaceDesc.ddsCaps.dwCaps and DDSCAPS_VIDEOMEMORY<>0) and
  3251.       (idoHardware in Options) and (Surface.DDraw.DriverCaps.dwCaps and DDCAPS_3D<>0);
  3252.  
  3253.     if Surface.DDraw.DriverCaps.ddsCaps.dwCaps and DDSCAPS_TEXTURE=0 then
  3254.       SupportHardware := False;
  3255.  
  3256.     {  Direct3D  }
  3257.     InitDevice;
  3258.                           
  3259.     if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil)<>D3D_OK then
  3260.     begin
  3261.       SupportHardware := False;
  3262.       InitDevice;
  3263.       if D3D3.CreateDevice(D3DDeviceGUID, Surface.ISurface4, D3DDevice3, nil)<>D3D_OK then
  3264.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DDevice3']);
  3265.     end;
  3266.  
  3267.     if SupportHardware then NowOptions := NowOptions + [idoHardware];
  3268.  
  3269.     D3DDevice2 := D3DDevice3 as IDirect3DDevice2;
  3270.     D3DDevice := D3DDevice3 as IDirect3DDevice;
  3271.  
  3272.     with D3DDevice3 do
  3273.     begin
  3274.       SetRenderState(D3DRENDERSTATE_DITHERENABLE, Ord(idoDither in Options));
  3275.       SetRenderState(D3DRENDERSTATE_ZENABLE, Ord(ZBuffer<>nil));
  3276.       SetRenderState(D3DRENDERSTATE_ZWRITEENABLE, Ord(ZBuffer<>nil));
  3277.     end;
  3278.  
  3279.     {  Direct3D Retained Mode}
  3280.     if idoRetainedMode in Options then
  3281.     begin
  3282.       NowOptions := NowOptions + [idoRetainedMode];
  3283.  
  3284.       if D3DRM2=nil then
  3285.       begin
  3286.         if TDirect3DRMCreate(DXLoadLibrary('D3DRM.dll', 'Direct3DRMCreate'))(D3DRM)<>D3DRM_OK then
  3287.           raise EDXDrawError.CreateFmt(SCannotInitialized, [SDirect3DRM]);
  3288.         D3DRM2 := D3DRM as IDirect3DRM2;
  3289.       end;
  3290.  
  3291.       if D3DRM2.CreateDeviceFromD3D(D3D2, D3DDevice2, D3DRMDevice2)<>D3DRM_OK then
  3292.         raise EDXDrawError.CreateFmt(SCannotMade, ['IDirect3DRMDevice2']);
  3293.  
  3294.       D3DRMDevice2.SetBufferCount(2);
  3295.       D3DRMDevice := D3DRMDevice2 as IDirect3DRMDevice;
  3296.  
  3297.       {  Rendering state setting  }
  3298.       D3DRMDevice.SetQuality(D3DRMLIGHT_ON or D3DRMFILL_SOLID or D3DRMSHADE_GOURAUD);
  3299.       D3DRMDevice.SetTextureQuality(D3DRMTEXTURE_NEAREST);
  3300.       D3DRMDevice.SetDither(idoDither in Options);
  3301.  
  3302.       if idoDither in Options then
  3303.         NowOptions := NowOptions + [idoDither];
  3304.  
  3305.       if Surface.BitCount=8 then
  3306.       begin
  3307.         D3DRMDevice.SetShades(8);
  3308.         D3DRM.SetDefaultTextureColors(64);
  3309.         D3DRM.SetDefaultTextureShades(32);
  3310.       end else
  3311.       begin
  3312.         D3DRM.SetDefaultTextureColors(64);
  3313.         D3DRM.SetDefaultTextureShades(32);
  3314.       end;
  3315.  
  3316.       {  Frame making  }
  3317.       if Scene=nil then
  3318.       begin
  3319.         D3DRM.CreateFrame(nil, Scene);
  3320.         D3DRM.CreateFrame(Scene, Camera);
  3321.         Camera.SetPosition(Camera, 0, 0, 0);
  3322.       end;
  3323.  
  3324.       {  Viewport making  }
  3325.       D3DRM.CreateViewport(D3DRMDevice, Camera, 0, 0,
  3326.         Surface.Width, Surface.Height, Viewport);
  3327.       Viewport.SetBack(5000.0);
  3328.     end;
  3329.   except
  3330.     FreeZBufferSurface(Surface, ZBuffer);
  3331.     D3D := nil;
  3332.     D3D2 := nil;
  3333.     D3D3 := nil;
  3334.     D3DDevice := nil;
  3335.     D3DDevice2 := nil;
  3336.     D3DDevice3 := nil;
  3337.     D3DRM := nil;
  3338.     D3DRM2 := nil;
  3339.     D3DRMDevice := nil;
  3340.     D3DRMDevice2 := nil;
  3341.     Viewport := nil;
  3342.     Scene := nil;
  3343.     Camera := nil;
  3344.     raise;
  3345.   end;
  3346. end;
  3347.  
  3348. type
  3349.  
  3350.   {  TDXDrawDriver  }
  3351.  
  3352.   TDXDrawDriver = class
  3353.   private
  3354.     FDXDraw: TCustomDXDraw;
  3355.     constructor Create(ADXDraw: TCustomDXDraw); virtual;
  3356.     destructor Destroy; override;
  3357.     procedure Finalize; virtual;
  3358.     procedure Flip; virtual; abstract;
  3359.     procedure Initialize; virtual; abstract;
  3360.     procedure Initialize3D;
  3361.     function SetSize(AWidth, AHeight: Integer): Boolean; virtual;
  3362.     function Restore: Boolean;
  3363.   end;
  3364.  
  3365.   TDXDrawDriverBlt = class(TDXDrawDriver)
  3366.   private
  3367.     procedure Flip; override;
  3368.     procedure Initialize; override;
  3369.     procedure InitializeSurface;
  3370.     function SetSize(AWidth, AHeight: Integer): Boolean; override;
  3371.   end;
  3372.  
  3373.   TDXDrawDriverFlip = class(TDXDrawDriver)
  3374.   private
  3375.     procedure Flip; override;
  3376.     procedure Initialize; override;
  3377.   end;
  3378.  
  3379. {  TDXDrawDriver  }
  3380.  
  3381. constructor TDXDrawDriver.Create(ADXDraw: TCustomDXDraw);
  3382. var
  3383.   AOptions: TInitializeDirect3DOptions;
  3384. begin
  3385.   inherited Create;
  3386.   FDXDraw := ADXDraw;
  3387.  
  3388.   {  Driver selection and Display mode optimizationn }
  3389.   if FDXDraw.FOptions*[doFullScreen, doSystemMemory, do3D, doHardware]=
  3390.     [doFullScreen, do3D, doHardware] then
  3391.   begin
  3392.     AOptions := [];
  3393.     with FDXDraw do
  3394.     begin
  3395.       if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
  3396.       if FDXDraw.Display.FixedBitCount then AOptions := AOptions + [idoOptimizeDisplayMode];
  3397.  
  3398.       if doHardware in Options then AOptions := AOptions + [idoHardware];
  3399.       if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
  3400.       if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
  3401.       if doRGB in Options then AOptions := AOptions + [idoRGB];
  3402.       if doMono in Options then AOptions := AOptions + [idoMono];
  3403.       if doDither in Options then AOptions := AOptions + [idoDither];
  3404.     end;
  3405.  
  3406.     Direct3DInitializing_DXDraw(AOptions, FDXDraw);
  3407.   end;
  3408.  
  3409.   if FDXDraw.Options*[doFullScreen, doHardware, doSystemMemory]=
  3410.     [doFullScreen, doHardware] then
  3411.     FDXDraw.FDDraw := TDirectDraw.Create(PGUID(FDXDraw.FDriver))
  3412.   else
  3413.     FDXDraw.FDDraw := TDirectDraw.Create(nil);
  3414. end;
  3415.  
  3416. procedure TDXDrawDriver.Initialize3D;
  3417. const
  3418.   DXDrawOptions3D = [doHardware, doRetainedMode, doSelectDriver, doZBuffer,
  3419.     doRGB, doMono, doDither];
  3420. var
  3421.   AOptions: TInitializeDirect3DOptions;
  3422. begin
  3423.   AOptions := [];
  3424.   with FDXDraw do
  3425.   begin
  3426.     if doHardware in FOptions then AOptions := AOptions + [idoHardware];
  3427.     if doRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
  3428.     if doSelectDriver in FOptions then AOptions := AOptions + [idoSelectDriver];
  3429.     if doZBuffer in FOptions then AOptions := AOptions + [idoZBuffer];
  3430.     if doRGB in FOptions then AOptions := AOptions + [idoRGB];
  3431.     if doMono in FOptions then AOptions := AOptions + [idoMono];
  3432.     if doDither in FOptions then AOptions := AOptions + [idoDither];
  3433.  
  3434.     InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
  3435.       FD3DRM, FD3DRM2, FD3DRMDevice, FD3DRMDevice2, FViewport, FScene, FCamera,
  3436.       FHWDeviceDesc, FHELDeviceDesc, FD3DDeviceDesc, AOptions);
  3437.  
  3438.     FNowOptions := FNowOptions - DXDrawOptions3D;
  3439.  
  3440.     if idoHardware in AOptions then FNowOptions := FNowOptions + [doHardware];
  3441.     if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [doRetainedMode];
  3442.     if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [doSelectDriver];
  3443.     if idoZBuffer in AOptions then FNowOptions := FNowOptions + [doZBuffer];
  3444.     if idoRGB in AOptions then FNowOptions := FNowOptions + [doRGB];
  3445.     if idoMono in AOptions then FNowOptions := FNowOptions + [doMono];
  3446.     if idoDither in AOptions then FNowOptions := FNowOptions + [doDither];
  3447.   end;
  3448. end;
  3449.  
  3450. destructor TDXDrawDriver.Destroy;
  3451. begin
  3452.   Finalize;
  3453.   FDXDraw.FDDraw.Free;
  3454.   inherited Destroy;
  3455. end;
  3456.  
  3457. procedure TDXDrawDriver.Finalize;
  3458. begin
  3459.   with FDXDraw do
  3460.   begin
  3461.     FViewport := nil;
  3462.     FCamera := nil;
  3463.     FScene := nil;
  3464.  
  3465.     FD3DRMDevice := nil;
  3466.     FD3DRMDevice2 := nil;
  3467.     FD3DDevice := nil;
  3468.     FD3DDevice2 := nil;
  3469.     FD3DDevice3 := nil;
  3470.     FD3D := nil;
  3471.     FD3D2 := nil;
  3472.     FD3D3 := nil;
  3473.  
  3474.     FreeZBufferSurface(FSurface, FZBuffer);
  3475.  
  3476.     FClipper.Free;  FClipper := nil;
  3477.     FPalette.Free;  FPalette := nil;
  3478.     FSurface.Free;  FSurface := nil;
  3479.     FPrimary.Free;  FPrimary := nil;
  3480.  
  3481.     FD3DRM2 := nil;
  3482.     FD3DRM := nil;
  3483.   end;
  3484. end;
  3485.  
  3486. function TDXDrawDriver.Restore: Boolean;
  3487. begin
  3488.   Result := FDXDraw.FPrimary.Restore and FDXDraw.FSurface.Restore;
  3489.   if Result then
  3490.   begin                  
  3491.     FDXDraw.FPrimary.Fill(0);
  3492.     FDXDraw.FSurface.Fill(0);
  3493.   end;
  3494. end;
  3495.  
  3496. function TDXDrawDriver.SetSize(AWidth, AHeight: Integer): Boolean;
  3497. begin
  3498.   Result := False;
  3499. end;
  3500.  
  3501. {  TDXDrawDriverBlt  }
  3502.  
  3503. function TDXDrawRGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads;
  3504.   AllowPalette256: Boolean): TPaletteEntries;
  3505. var
  3506.   Entries: TPaletteEntries;
  3507.   dc: THandle;
  3508.   i: Integer;
  3509. begin
  3510.   Result := RGBQuadsToPaletteEntries(RGBQuads);
  3511.  
  3512.   if not AllowPalette256 then
  3513.   begin
  3514.     dc := GetDC(0);
  3515.     GetSystemPaletteEntries(dc, 0, 256, Entries);
  3516.     ReleaseDC(0, dc);
  3517.  
  3518.     for i:=0 to 9 do
  3519.       Result[i] := Entries[i];
  3520.  
  3521.     for i:=256-10 to 255 do
  3522.       Result[i] := Entries[i];
  3523.   end;
  3524.  
  3525.   for i:=0 to 255 do
  3526.     Result[i].peFlags := D3DPAL_READONLY;
  3527. end;
  3528.  
  3529. function CreateHalftonePalette(R, G, B: Integer): TPaletteEntries;
  3530. var
  3531.   i: Integer;
  3532. begin
  3533.   for i:=0 to 255 do
  3534.     with Result[i] do
  3535.     begin
  3536.       peRed   := ((i shr (G+B-1)) and (1 shl R-1)) * 255 div (1 shl R-1);
  3537.       peGreen := ((i shr (B-1)) and (1 shl G-1)) * 255 div (1 shl G-1);
  3538.       peBlue  := ((i shr 0) and (1 shl B-1)) * 255 div (1 shl B-1);
  3539.       peFlags := 0;
  3540.     end;
  3541. end;
  3542.  
  3543. procedure TDXDrawDriverBlt.Flip;
  3544. var
  3545.   pt: TPoint;
  3546.   Dest: TRect;
  3547.   DF: DDBLTFX;
  3548. begin
  3549.   pt := FDXDraw.ClientToScreen(Point(0, 0));
  3550.  
  3551.   if doStretch in FDXDraw.NowOptions then
  3552.   begin
  3553.     Dest := Bounds(pt.x, pt.y, FDXDraw.Width, FDXDraw.Height);
  3554.   end else
  3555.   begin
  3556.     if doCenter in FDXDraw.NowOptions then
  3557.     begin
  3558.       Inc(pt.x, (FDXDraw.Width-FDXDraw.FSurface.Width) div 2);
  3559.       Inc(pt.y, (FDXDraw.Height-FDXDraw.FSurface.Height) div 2);
  3560.     end;
  3561.  
  3562.     Dest := Bounds(pt.x, pt.y, FDXDraw.FSurface.Width, FDXDraw.FSurface.Height);
  3563.   end;
  3564.   
  3565.   if doWaitVBlank in FDXDraw.NowOptions then
  3566.     FDXDraw.FDDraw.DXResult := FDXDraw.FDDraw.IDraw.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
  3567.  
  3568.   DF.dwsize := SizeOf(DF);
  3569.   DF.dwDDFX := 0;
  3570.  
  3571.   FDXDraw.FPrimary.Blt(Dest, FDXDraw.FSurface.ClientRect, DDBLT_WAIT, df, FDXDraw.FSurface);
  3572. end;
  3573.  
  3574. procedure TDXDrawDriverBlt.Initialize;
  3575. const
  3576.   PrimaryDesc: DDSURFACEDESC = (
  3577.       dwSize: SizeOf(PrimaryDesc);
  3578.       dwFlags: DDSD_CAPS;
  3579.       ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE)
  3580.       );
  3581. var
  3582.   Entries: TPaletteEntries;
  3583.   PaletteCaps: Integer;
  3584. begin
  3585.   {  Surface making  }
  3586.   FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  3587.   if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
  3588.     raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
  3589.  
  3590.   FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  3591.  
  3592.   {  Clipper making  }
  3593.   FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
  3594.   FDXDraw.FClipper.Handle := FDXDraw.Handle;
  3595.   FDXDraw.FPrimary.Clipper := FDXDraw.FClipper;
  3596.  
  3597.   {  Palette making  }
  3598.   PaletteCaps := DDPCAPS_8BIT or DDPCAPS_INITIALIZE;
  3599.   if doAllowPalette256 in FDXDraw.NowOptions then
  3600.     PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
  3601.  
  3602.   FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
  3603.   Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
  3604.     doAllowPalette256 in FDXDraw.NowOptions);
  3605.   FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
  3606.  
  3607.   FDXDraw.FPrimary.Palette := FDXDraw.Palette;
  3608.  
  3609.   InitializeSurface;
  3610. end;
  3611.  
  3612. procedure TDXDrawDriverBlt.InitializeSurface;
  3613. var
  3614.   ddsd: DDSURFACEDESC;
  3615. begin
  3616.   FDXDraw.FSurface.IDDSurface := nil;
  3617.  
  3618.   {  Surface making  }
  3619.   FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
  3620.  
  3621.   FillChar(ddsd, SizeOf(ddsd), 0);
  3622.   with ddsd do
  3623.   begin
  3624.     dwSize := SizeOf(ddsd);
  3625.     dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
  3626.     dwWidth := Max(FDXDraw.FSurfaceWidth, 1);
  3627.     dwHeight := Max(FDXDraw.FSurfaceHeight, 1);
  3628.     ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN;
  3629.     if doSystemMemory in FDXDraw.Options then
  3630.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  3631.     if do3D in FDXDraw.FNowOptions then
  3632.       ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
  3633.   end;
  3634.  
  3635.   if not FDXDraw.FSurface.CreateSurface(ddsd) then
  3636.   begin
  3637.     ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY;
  3638.     if not FDXDraw.FSurface.CreateSurface(ddsd) then
  3639.       raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  3640.   end;
  3641.  
  3642.   if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY=0 then
  3643.     FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
  3644.  
  3645.   FDXDraw.FSurface.Palette := FDXDraw.Palette;
  3646.   FDXDraw.FSurface.Fill(0);
  3647.  
  3648.   if do3D in FDXDraw.FNowOptions then
  3649.     Initialize3D;
  3650. end;
  3651.  
  3652. function TDXDrawDriverBlt.SetSize(AWidth, AHeight: Integer): Boolean;
  3653. begin
  3654.   Result := True;
  3655.  
  3656.   FDXDraw.FSurfaceWidth := Max(AWidth, 1);
  3657.   FDXDraw.FSurfaceHeight := Max(AHeight, 1);
  3658.  
  3659.   Inc(FDXDraw.FOffNotifyRestore);
  3660.   try
  3661.     FDXDraw.NotifyEventList(dxntFinalizeSurface);
  3662.  
  3663.     if FDXDraw.FCalledDoInitializeSurface then
  3664.     begin
  3665.       FDXDraw.FCalledDoInitializeSurface := False;
  3666.       FDXDraw.DoFinalizeSurface;
  3667.     end;
  3668.  
  3669.     InitializeSurface;
  3670.  
  3671.     FDXDraw.NotifyEventList(dxntInitializeSurface);
  3672.     FDXDraw.FCalledDoInitializeSurface := True; FDXDraw.DoInitializeSurface;
  3673.   finally
  3674.     Dec(FDXDraw.FOffNotifyRestore);
  3675.   end;
  3676. end;
  3677.  
  3678. {  TDXDrawDriverFlip  }
  3679.  
  3680. procedure TDXDrawDriverFlip.Flip;
  3681. begin
  3682.   if (FDXDraw.FForm<>nil) and (FDXDraw.FForm.Active) then
  3683.     FDXDraw.FPrimary.DXResult := FDXDraw.FPrimary.ISurface.Flip(nil, DDFLIP_WAIT)
  3684.   else
  3685.     FDXDraw.FPrimary.DXResult := 0;
  3686. end;
  3687.  
  3688. procedure TDXDrawDriverFlip.Initialize;
  3689. const
  3690.   DefPrimaryDesc: DDSURFACEDESC = (
  3691.       dwSize: SizeOf(DefPrimaryDesc);
  3692.       dwFlags: DDSD_CAPS or DDSD_BACKBUFFERCOUNT;
  3693.       dwBackBufferCount: 1;
  3694.       ddsCaps: (dwCaps: DDSCAPS_PRIMARYSURFACE or DDSCAPS_FLIP or DDSCAPS_COMPLEX)
  3695.       );
  3696.   BackBufferCaps: DDSCAPS = (dwCaps: DDSCAPS_BACKBUFFER);
  3697. var
  3698.   PrimaryDesc: DDSURFACEDESC;
  3699.   PaletteCaps: Integer;
  3700.   Entries: TPaletteEntries;
  3701.   DDSurface: IDirectDrawSurface;
  3702. begin
  3703.   {  Surface making  }
  3704.   PrimaryDesc := DefPrimaryDesc;
  3705.  
  3706.   if do3D in FDXDraw.FNowOptions then
  3707.     PrimaryDesc.ddsCaps.dwCaps := PrimaryDesc.ddsCaps.dwCaps or DDSCAPS_3DDEVICE;
  3708.  
  3709.   FDXDraw.FPrimary := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  3710.   if not FDXDraw.FPrimary.CreateSurface(PrimaryDesc) then
  3711.     raise EDXDrawError.CreateFmt(SCannotMade, [SDirectDrawPrimarySurface]);
  3712.  
  3713.   FDXDraw.FSurface := TDirectDrawSurface.Create(FDXDraw.FDDraw);
  3714.   if FDXDraw.FPrimary.ISurface.GetAttachedSurface(BackBufferCaps, DDSurface)=DD_OK then
  3715.     FDXDraw.FSurface.IDDSurface := DDSurface;
  3716.  
  3717.   FDXDraw.FNowOptions := FDXDraw.FNowOptions - [doSystemMemory];
  3718.   if FDXDraw.FSurface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_SYSTEMMEMORY<>0 then
  3719.     FDXDraw.FNowOptions := FDXDraw.FNowOptions + [doSystemMemory];
  3720.  
  3721.   {  Clipper making of dummy  }
  3722.   FDXDraw.FClipper := TDirectDrawClipper.Create(FDXDraw.FDDraw);
  3723.  
  3724.   {  Palette making  }
  3725.   PaletteCaps := DDPCAPS_8BIT;
  3726.   if doAllowPalette256 in FDXDraw.Options then
  3727.     PaletteCaps := PaletteCaps or DDPCAPS_ALLOW256;
  3728.  
  3729.   FDXDraw.FPalette := TDirectDrawPalette.Create(FDXDraw.FDDraw);
  3730.   Entries := TDXDrawRGBQuadsToPaletteEntries(FDXDraw.ColorTable,
  3731.     doAllowPalette256 in FDXDraw.NowOptions);
  3732.   FDXDraw.FPalette.CreatePalette(PaletteCaps, Entries);
  3733.                           
  3734.   FDXDraw.FPrimary.Palette := FDXDraw.Palette;
  3735.   FDXDraw.FSurface.Palette := FDXDraw.Palette;
  3736.  
  3737.   if do3D in FDXDraw.FNowOptions then
  3738.     Initialize3D;
  3739. end;
  3740.  
  3741. constructor TCustomDXDraw.Create(AOwner: TComponent);
  3742. var
  3743.   Entries: TPaletteEntries;
  3744.   dc: THandle;
  3745. begin
  3746.   FNotifyEventList := TList.Create;
  3747.   inherited Create(AOwner);
  3748.   FAutoInitialize := True;
  3749.   FDisplay := TDirectDrawDisplay.Create(Self);
  3750.  
  3751.   Options := [doAllowReboot, doWaitVBlank, doCenter, doHardware, doRetainedMode,
  3752.     doSelectDriver, doRGB, doMono, doDither];
  3753.  
  3754.   FAutoSize := True;
  3755.  
  3756.   dc := GetDC(0);
  3757.   GetSystemPaletteEntries(dc, 0, 256, Entries);
  3758.   ReleaseDC(0, dc);
  3759.  
  3760.   ColorTable := PaletteEntriesToRGBQuads(Entries);
  3761.   DefColorTable := ColorTable;
  3762.  
  3763.   Width := 100;
  3764.   Height := 100;
  3765.   ParentColor := False;
  3766.   Color := clBtnFace;
  3767. end;
  3768.  
  3769. destructor TCustomDXDraw.Destroy;
  3770. begin
  3771.   Finalize;
  3772.   NotifyEventList(dxntDestroying);
  3773.   FDisplay.Free;
  3774.   FSubClass.Free; FSubClass := nil;
  3775.   FNotifyEventList.Free;
  3776.   inherited Destroy;
  3777. end;
  3778.  
  3779. class function TCustomDXDraw.Drivers: TDirectXDrivers;
  3780. begin
  3781.   Result := EnumDirectDrawDrivers;
  3782. end;
  3783.  
  3784. type
  3785.   PDXDrawNotifyEvent = ^TDXDrawNotifyEvent;
  3786.  
  3787. procedure TCustomDXDraw.RegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  3788. var
  3789.   Event: PDXDrawNotifyEvent;
  3790. begin
  3791.   UnRegisterNotifyEvent(NotifyEvent);
  3792.  
  3793.   Event := New(PDXDrawNotifyEvent);
  3794.   Event^ := NotifyEvent;
  3795.   FNotifyEventList.Add(Event);
  3796.  
  3797.   NotifyEvent(Self, dxntSetSurfaceSize);
  3798.  
  3799.   if Initialized then
  3800.   begin
  3801.     NotifyEvent(Self, dxntInitialize);
  3802.     if FOffNotifyRestore=0 then NotifyEvent(Self, dxntRestore);
  3803.   end;
  3804. end;
  3805.  
  3806. procedure TCustomDXDraw.UnRegisterNotifyEvent(NotifyEvent: TDXDrawNotifyEvent);
  3807. var
  3808.   Event: PDXDrawNotifyEvent;
  3809.   i: Integer;
  3810. begin
  3811.   for i:=0 to FNotifyEventList.Count-1 do
  3812.   begin
  3813.     Event := FNotifyEventList[i];
  3814.     if (TMethod(Event^).Code = TMethod(NotifyEvent).Code) and
  3815.       (TMethod(Event^).Data = TMethod(NotifyEvent).Data) then
  3816.     begin
  3817.       FreeMem(Event);
  3818.       FNotifyEventList.Delete(i);
  3819.  
  3820.       if Initialized then
  3821.         NotifyEvent(Self, dxntFinalize);
  3822.  
  3823.       Break;
  3824.     end;
  3825.   end;
  3826. end;
  3827.  
  3828. procedure TCustomDXDraw.NotifyEventList(NotifyType: TDXDrawNotifyType);
  3829. var
  3830.   i: Integer;
  3831. begin
  3832.   for i:=FNotifyEventList.Count-1 downto 0 do
  3833.     PDXDrawNotifyEvent(FNotifyEventList[i])^(Self, NotifyType);
  3834. end;
  3835.  
  3836. procedure TCustomDXDraw.FormWndProc(var Message: TMessage; DefWindowProc: TWndMethod);
  3837.  
  3838.   procedure FlipToGDISurface;
  3839.   begin
  3840.     if Initialized and (FNowOptions*[doFullScreen, doFlip]=[doFullScreen, doFlip]) then
  3841.       DDraw.IDraw.FlipToGDISurface;
  3842.   end;
  3843.  
  3844. begin
  3845.   case Message.Msg of
  3846.     {CM_ACTIVATE:
  3847.         begin
  3848.           DefWindowProc(Message);
  3849.           if AutoInitialize and (not FInitalized2) then
  3850.             Initialize;
  3851.           Exit;
  3852.         end;   }
  3853.     WM_WINDOWPOSCHANGED:
  3854.         begin
  3855.           if TWMWindowPosChanged(Message).WindowPos^.flags and SWP_SHOWWINDOW<>0 then
  3856.           begin
  3857.             DefWindowProc(Message);
  3858.             if AutoInitialize and (not FInitialized2) then
  3859.               Initialize;
  3860.             Exit;
  3861.           end;
  3862.         end;
  3863.     WM_ACTIVATE:
  3864.         begin
  3865.           if TWMActivate(Message).Active=WA_INACTIVE then
  3866.             FlipToGDISurface;
  3867.         end;
  3868.     WM_INITMENU:
  3869.         begin
  3870.           FlipToGDISurface;
  3871.         end;
  3872.     WM_CLOSE:
  3873.         begin
  3874.           Finalize;
  3875.         end;
  3876.   end;      
  3877.   DefWindowProc(Message);
  3878. end;
  3879.  
  3880. procedure TCustomDXDraw.DoFinalize;
  3881. begin
  3882.   if Assigned(FOnFinalize) then FOnFinalize(Self);
  3883. end;
  3884.  
  3885. procedure TCustomDXDraw.DoFinalizeSurface;
  3886. begin
  3887.   if Assigned(FOnFinalizeSurface) then FOnFinalizeSurface(Self);
  3888. end;
  3889.  
  3890. procedure TCustomDXDraw.DoInitialize;
  3891. begin
  3892.   if Assigned(FOnInitialize) then FOnInitialize(Self);
  3893. end;
  3894.  
  3895. procedure TCustomDXDraw.DoInitializeSurface;
  3896. begin
  3897.   if Assigned(FOnInitializeSurface) then FOnInitializeSurface(Self);
  3898. end;
  3899.  
  3900. procedure TCustomDXDraw.DoInitializing;
  3901. begin
  3902.   if Assigned(FOnInitializing) then FOnInitializing(Self);
  3903. end;
  3904.  
  3905. procedure TCustomDXDraw.DoRestoreSurface;
  3906. begin
  3907.   if Assigned(FOnRestoreSurface) then FOnRestoreSurface(Self);
  3908. end;
  3909.  
  3910. procedure TCustomDXDraw.Finalize;
  3911. begin
  3912.   if FInternalInitialized then
  3913.   begin
  3914.     FSurfaceWidth := SurfaceWidth;
  3915.     FSurfaceHeight := SurfaceHeight;
  3916.  
  3917.     FDisplay.FModes.Clear;
  3918.  
  3919.     FUpdating := True;
  3920.     try
  3921.       try
  3922.         try
  3923.           if FCalledDoInitializeSurface then
  3924.           begin
  3925.             FCalledDoInitializeSurface := False;
  3926.             DoFinalizeSurface;
  3927.           end;        
  3928.         finally
  3929.           NotifyEventList(dxntFinalizeSurface);
  3930.         end;
  3931.       finally
  3932.         try
  3933.           if FCalledDoInitialize then
  3934.           begin
  3935.             FCalledDoInitialize := False;
  3936.             DoFinalize;
  3937.           end;
  3938.         finally
  3939.           NotifyEventList(dxntFinalize);
  3940.         end;
  3941.       end;
  3942.     finally
  3943.       FInternalInitialized := False;
  3944.       FInitialized := False;
  3945.  
  3946.       SetOptions(FOptions);
  3947.  
  3948.       FDXDrawDriver.Free; FDXDrawDriver := nil;
  3949.       FUpdating := False;
  3950.     end;
  3951.   end;
  3952. end;
  3953.  
  3954. procedure TCustomDXDraw.Flip;
  3955. begin
  3956.   if Initialized and (not FUpdating) then
  3957.   begin
  3958.     if TryRestore then
  3959.       TDXDrawDriver(FDXDrawDriver).Flip;
  3960.   end;
  3961. end;
  3962.  
  3963. function TCustomDXDraw.GetCanDraw: Boolean;
  3964. begin
  3965.   Result := Initialized and (not FUpdating) and (Surface.IDDSurface<>nil) and
  3966.     TryRestore;
  3967. end;
  3968.  
  3969. function TCustomDXDraw.GetCanPaletteAnimation: Boolean;
  3970. begin
  3971.   Result := Initialized and (not FUpdating) and (doFullScreen in FNowOptions)
  3972.     and (DDraw.DisplayMode.ddpfPixelFormat.dwRGBBitCount<=8);
  3973. end;
  3974.  
  3975. function TCustomDXDraw.GetSurfaceHeight: Integer;
  3976. begin
  3977.   if Surface.IDDSurface<>nil then
  3978.     Result := Surface.Height
  3979.   else
  3980.     Result := FSurfaceHeight;
  3981. end;
  3982.  
  3983. function TCustomDXDraw.GetSurfaceWidth: Integer;
  3984. begin
  3985.   if Surface.IDDSurface<>nil then
  3986.     Result := Surface.Width
  3987.   else
  3988.     Result := FSurfaceWidth;
  3989. end;
  3990.  
  3991. procedure TCustomDXDraw.Loaded;
  3992. begin
  3993.   inherited Loaded;
  3994.  
  3995.   if AutoSize then
  3996.   begin
  3997.     FSurfaceWidth := Width;
  3998.     FSurfaceHeight := Height;
  3999.   end;
  4000.  
  4001.   NotifyEventList(dxntSetSurfaceSize);
  4002.  
  4003.   if FAutoInitialize and (not (csDesigning in ComponentState)) then
  4004.   begin
  4005.     if {(not (doFullScreen in FOptions)) or }(FSubClass=nil) then
  4006.       Initialize;
  4007.   end;
  4008. end;
  4009.  
  4010. procedure TCustomDXDraw.Initialize;
  4011. begin
  4012.   FInitialized2 := True;
  4013.  
  4014.   Finalize;
  4015.  
  4016.   if FForm=nil then
  4017.     raise EDXDrawError.Create(SNoForm);
  4018.  
  4019.   try
  4020.     DoInitializing;
  4021.  
  4022.     {  Initialization.  }
  4023.     FUpdating := True;
  4024.     try
  4025.       FInternalInitialized := True;
  4026.  
  4027.       NotifyEventList(dxntInitializing);
  4028.  
  4029.       {  DirectDraw initialization.  }
  4030.       if doFlip in FNowOptions then
  4031.       begin
  4032.         FDXDrawDriver := TDXDrawDriverFlip.Create(Self)
  4033.       end else
  4034.         FDXDrawDriver := TDXDrawDriverBlt.Create(Self);
  4035.  
  4036.       {  Window handle setting.  }
  4037.       SetCooperativeLevel;
  4038.  
  4039.       {  Set display mode.  }
  4040.       if doFullScreen in FNowOptions then
  4041.       begin
  4042.         if not Display.DynSetSize(Display.Width, Display.Height, Display.BitCount) then
  4043.           raise EDXDrawError.CreateFmt(SDisplaymodeChange, [Display.Width, Display.Height, Display.BitCount]);
  4044.       end;
  4045.  
  4046.       {  Resource initialization.  }
  4047.       if AutoSize then
  4048.       begin
  4049.         FSurfaceWidth := Width;
  4050.         FSurfaceHeight := Height;
  4051.       end;
  4052.  
  4053.       TDXDrawDriver(FDXDrawDriver).Initialize;
  4054.     finally
  4055.       FUpdating := False;
  4056.     end;
  4057.   except
  4058.     Finalize;
  4059.     raise;
  4060.   end;
  4061.  
  4062.   FInitialized := True;
  4063.  
  4064.   Inc(FOffNotifyRestore);
  4065.   try
  4066.     NotifyEventList(dxntSetSurfaceSize);
  4067.     NotifyEventList(dxntInitialize);
  4068.     FCalledDoInitialize := True; DoInitialize;
  4069.  
  4070.     NotifyEventList(dxntInitializeSurface);
  4071.     FCalledDoInitializeSurface := True; DoInitializeSurface;
  4072.   finally
  4073.     Dec(FOffNotifyRestore);
  4074.   end;
  4075.  
  4076.   Restore;
  4077. end;
  4078.  
  4079. procedure TCustomDXDraw.Paint;
  4080. var
  4081.   Old: TDXDrawOptions;
  4082.   w, h: Integer;
  4083.   s: string;
  4084. begin
  4085.   inherited Paint;
  4086.   if (csDesigning in ComponentState) then
  4087.   begin
  4088.     Canvas.Brush.Style := bsClear;
  4089.     Canvas.Pen.Color := clBlack;
  4090.     Canvas.Pen.Style := psDash;
  4091.     Canvas.Rectangle(0, 0, Width, Height);
  4092.  
  4093.     Canvas.Pen.Style := psSolid;
  4094.     Canvas.Pen.Color := clGray;
  4095.     Canvas.MoveTo(0, 0);
  4096.     Canvas.LineTo(Width, Height);
  4097.  
  4098.     Canvas.MoveTo(0, Height);
  4099.     Canvas.LineTo(Width, 0);
  4100.  
  4101.     s := Format('(%s)', [ClassName]);
  4102.  
  4103.     w := Canvas.TextWidth(s);
  4104.     h := Canvas.TextHeight(s);
  4105.  
  4106.     Canvas.Brush.Style := bsSolid;
  4107.     Canvas.Brush.Color := clBtnFace;
  4108.     Canvas.TextOut(Width div 2-w div 2, Height div 2-h div 2, s);
  4109.   end else
  4110.   begin
  4111.     Old := FNowOptions;
  4112.     try
  4113.       FNowOptions := FNowOptions - [doWaitVBlank];
  4114.       Flip;
  4115.     finally         
  4116.       FNowOptions := Old;
  4117.     end;    
  4118.     if (Parent<>nil) and (Initialized) and (Surface.SurfaceDesc.ddscaps.dwCaps and DDSCAPS_VIDEOMEMORY<>0) then
  4119.       Parent.Invalidate;                                                                                
  4120.   end;
  4121. end;
  4122.  
  4123. function TCustomDXDraw.PaletteChanged(Foreground: Boolean): Boolean;
  4124. begin
  4125.   if Foreground then
  4126.   begin
  4127.     Restore;
  4128.     Result := True;
  4129.   end else
  4130.     Result := False;
  4131. end;
  4132.  
  4133. procedure TCustomDXDraw.Render;
  4134. begin
  4135.   if FInitialized and (do3D in FNowOptions) and (doRetainedMode in FNowOptions) then
  4136.   begin
  4137.     asm FInit end;
  4138.     FViewport.Clear;
  4139.     FViewport.Render(FScene);
  4140.     FD3DRMDevice.Update;
  4141.     asm FInit end;
  4142.   end;
  4143. end;
  4144.  
  4145. procedure TCustomDXDraw.Restore;
  4146. begin
  4147.   if Initialized and (not FUpdating) then
  4148.   begin
  4149.     FUpdating := True;
  4150.     try
  4151.       if TDXDrawDriver(FDXDrawDriver).Restore then
  4152.       begin
  4153.         Primary.Palette := Palette;
  4154.         Surface.Palette := Palette;
  4155.  
  4156.         SetColorTable(DefColorTable);
  4157.         NotifyEventList(dxntRestore);
  4158.         DoRestoreSurface;
  4159.         SetColorTable(ColorTable);
  4160.       end;
  4161.     finally
  4162.       FUpdating := False;
  4163.     end;
  4164.   end;
  4165. end;
  4166.  
  4167. procedure TCustomDXDraw.SetAutoSize(Value: Boolean);
  4168. begin
  4169.   if FAutoSize<>Value then
  4170.   begin
  4171.     FAutoSize := Value;
  4172.     if FAutoSize then
  4173.       SetSize(Width, Height);
  4174.   end;
  4175. end;
  4176.  
  4177. procedure TCustomDXDraw.Setbounds(ALeft, ATop, AWidth, AHeight: Integer);
  4178. begin
  4179.   inherited Setbounds(ALeft, ATop, AWidth, AHeight);
  4180.   if FAutoSize and (not FUpdating) then
  4181.     SetSize(AWidth, AHeight);
  4182. end;
  4183.  
  4184. procedure TCustomDXDraw.SetColorTable(const ColorTable: TRGBQuads);
  4185. var
  4186.   Entries: TPaletteEntries;
  4187. begin
  4188.   if Initialized and (Palette<>nil) then
  4189.   begin
  4190.     Entries := TDXDrawRGBQuadsToPaletteEntries(ColorTable,
  4191.       doAllowPalette256 in FNowOptions);
  4192.     Palette.SetEntries(0, 256, Entries);
  4193.   end;
  4194. end;
  4195.  
  4196. procedure TCustomDXDraw.SetCooperativeLevel;
  4197. var
  4198.   Flags: Integer;
  4199.   Control: TWinControl;
  4200. begin
  4201.   Control := FForm;
  4202.   if Control=nil then
  4203.     Control := Self;
  4204.  
  4205.   if doFullScreen in FNowOptions then
  4206.   begin
  4207.     Flags := DDSCL_FULLSCREEN or DDSCL_EXCLUSIVE or DDSCL_ALLOWMODEX;
  4208.     if doNoWindowChange in FNowOptions then
  4209.       Flags := Flags or DDSCL_NOWINDOWCHANGES;
  4210.     if doAllowReboot in FNowOptions then
  4211.       Flags := Flags or DDSCL_ALLOWREBOOT;
  4212.   end else
  4213.     Flags := DDSCL_NORMAL;
  4214.  
  4215.   DDraw.DXResult := DDraw.IDraw.SetCooperativeLevel(Control.Handle, Flags);
  4216. end;
  4217.  
  4218. procedure TCustomDXDraw.SetDisplay(Value: TDirectDrawDisplay);
  4219. begin
  4220.   FDisplay.Assign(Value);
  4221. end;
  4222.  
  4223. procedure TCustomDXDraw.SetDriver(Value: PGUID);
  4224. begin
  4225.   if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
  4226.   begin
  4227.     FDriverGUID := Value^;
  4228.     FDriver := @FDriverGUID;
  4229.   end else
  4230.     FDriver := Value;
  4231. end;
  4232.  
  4233. procedure TCustomDXDraw.SetOptions(Value: TDXDrawOptions);
  4234. const
  4235.   DXDrawOptions = [doFullScreen, doNoWindowChange, doAllowReboot, doWaitVBlank,
  4236.     doAllowPalette256, doSystemMemory, doStretch, doCenter, doFlip, do3D,
  4237.     doHardware, doRetainedMode, doSelectDriver, doZBuffer,
  4238.     doRGB, doMono, doDither];
  4239.   InitOptions = [doFullScreen, doNoWindowChange, doAllowReboot,
  4240.     doAllowPalette256, doSystemMemory, doFlip, do3D,
  4241.     doHardware, doRetainedMode, doSelectDriver, doZBuffer,
  4242.     doRGB, doMono];
  4243. var
  4244.   OldOptions: TDXDrawOptions;
  4245. begin
  4246.   FOptions := Value;
  4247.  
  4248.   if Initialized then
  4249.   begin
  4250.     OldOptions := FNowOptions;
  4251.     FNowOptions := FNowOptions*InitOptions+FOptions*(DXDrawOptions - InitOptions);
  4252.  
  4253.     if not (do3D in FNowOptions) then
  4254.       FNowOptions := FNowOptions - [doHardware, doRetainedMode,
  4255.         doSelectDriver, doZBuffer, doRGB, doMono, doDither];
  4256.  
  4257.     if do3D in FNowOptions then
  4258.     begin
  4259.       if (FNowOptions-OldOptions)*[doDither]<>(OldOptions-FNowOptions)*[doDither] then
  4260.       begin
  4261.         if FD3DRMDevice<>nil then
  4262.         begin
  4263.          FD3DRMDevice.SetDither(doDither in FNowOptions);
  4264.         end else
  4265.         if FD3DDevice2<>nil then
  4266.         begin
  4267.           with FD3DDevice2 do
  4268.             SetRenderState(D3DRENDERSTATE_DITHERENABLE, Ord(doDither in FNowOptions));
  4269.         end;
  4270.       end;
  4271.     end;
  4272.   end else
  4273.   begin
  4274.     FNowOptions := FOptions;
  4275.  
  4276.     if not (doFullScreen in FNowOptions) then
  4277.       FNowOptions := FNowOptions - [doNoWindowChange, doAllowReBoot, doAllowPalette256, doFlip];
  4278.  
  4279.     if not (do3D in FNowOptions) then
  4280.       FNowOptions := FNowOptions - [doHardware, doRetainedMode,
  4281.         doSelectDriver, doZBuffer, doRGB, doMono, doDither];
  4282.  
  4283.     if doSystemMemory in FNowOptions then
  4284.       FNowOptions := FNowOptions - [doFlip];
  4285.  
  4286.     FNowOptions := FNowOptions - [doHardware];
  4287.   end;
  4288. end;
  4289.  
  4290. procedure TCustomDXDraw.SetParent(AParent: TWinControl);
  4291. var
  4292.   Control: TWinControl;
  4293. begin
  4294.   inherited SetParent(AParent);
  4295.  
  4296.   FForm := nil;
  4297.   FSubClass.Free; FSubClass := nil;
  4298.  
  4299.   if not (csDesigning in ComponentState) then
  4300.   begin
  4301.     Control := Parent;
  4302.     while (Control<>nil) and (not (Control is TCustomForm)) do
  4303.       Control := Control.Parent;
  4304.     if Control<>nil then
  4305.     begin
  4306.       FForm := TCustomForm(Control);
  4307.       FSubClass := TControlSubClass.Create(Control, FormWndProc);
  4308.     end;
  4309.   end;
  4310. end;
  4311.  
  4312. procedure TCustomDXDraw.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  4313. begin
  4314.   if ((ASurfaceWidth<>SurfaceWidth) or (ASurfaceHeight<>SurfaceHeight)) and
  4315.     (not FUpdating) then
  4316.   begin
  4317.     if Initialized then
  4318.     begin
  4319.       try
  4320.         if not TDXDrawDriver(FDXDrawDriver).SetSize(ASurfaceWidth, ASurfaceHeight) then
  4321.           Exit;
  4322.       except
  4323.         Finalize;
  4324.         raise;
  4325.       end;
  4326.     end else
  4327.     begin
  4328.       FSurfaceWidth := ASurfaceWidth;
  4329.       FSurfaceHeight := ASurfaceHeight;
  4330.     end;
  4331.  
  4332.     NotifyEventList(dxntSetSurfaceSize);
  4333.   end;
  4334. end;
  4335.  
  4336. procedure TCustomDXDraw.SetSurfaceHeight(Value: Integer);
  4337. begin
  4338.   if ComponentState*[csReading, csLoading]=[] then
  4339.     SetSize(SurfaceWidth, Value)
  4340.   else
  4341.     FSurfaceHeight := Value;
  4342. end;
  4343.  
  4344. procedure TCustomDXDraw.SetSurfaceWidth(Value: Integer);
  4345. begin
  4346.   if ComponentState*[csReading, csLoading]=[] then
  4347.     SetSize(Value, SurfaceHeight)
  4348.   else
  4349.     FSurfaceWidth := Value;
  4350. end;
  4351.  
  4352. function TCustomDXDraw.TryRestore: Boolean;
  4353. begin
  4354.   Result := False;
  4355.  
  4356.   if Initialized and (not FUpdating) and (Primary.IDDSurface<>nil) then
  4357.   begin
  4358.     if (Primary.ISurface.IsLost=DDERR_SURFACELOST) then
  4359.     begin
  4360.       Restore;
  4361.       Result := Primary.ISurface.IsLost=DD_OK;
  4362.     end else
  4363.       Result := True;
  4364.   end;
  4365. end;
  4366.  
  4367. procedure TCustomDXDraw.UpdatePalette;
  4368. begin
  4369.   if Initialized then
  4370.   begin
  4371.     if FDDraw.FDriverCaps.dwPalCaps and DDPCAPS_VSYNC=0 then
  4372.       FDDraw.IDraw.WaitForVerticalBlank(DDWAITVB_BLOCKBEGIN, 0);
  4373.   end;
  4374.   SetColorTable(ColorTable);
  4375. end;
  4376.  
  4377. procedure TCustomDXDraw.WMCreate(var Message: TMessage);
  4378. begin
  4379.   inherited;
  4380.   if Initialized and (not FUpdating) then
  4381.   begin
  4382.     if Clipper<>nil then
  4383.       Clipper.Handle := Handle;
  4384.     SetCooperativeLevel;
  4385.   end;
  4386. end;
  4387.  
  4388. {  TCustomDX3D  }
  4389.  
  4390. constructor TCustomDX3D.Create(AOwner: TComponent);
  4391. begin
  4392.   inherited Create(AOwner);
  4393.   Options := [toHardware, toRetainedMode, toSelectDriver,
  4394.     toRGB, toMono, toDither];
  4395.   FSurfaceWidth := 320;
  4396.   FSurfaceHeight := 240;
  4397. end;
  4398.  
  4399. destructor TCustomDX3D.Destroy;
  4400. begin
  4401.   DXDraw := nil;
  4402.   inherited Destroy;
  4403. end;
  4404.  
  4405. procedure TCustomDX3D.DoFinalize;
  4406. begin
  4407.   if Assigned(FOnFinalize) then FOnFinalize(Self);
  4408. end;
  4409.  
  4410. procedure TCustomDX3D.DoInitialize;
  4411. begin
  4412.   if Assigned(FOnInitialize) then FOnInitialize(Self);
  4413. end;
  4414.  
  4415. procedure TCustomDX3D.Finalize;
  4416. begin
  4417.   if FInitialized then
  4418.   begin
  4419.     try
  4420.       if FInitFlag then
  4421.       begin
  4422.         FInitFlag := False;
  4423.         DoFinalize;
  4424.       end;
  4425.     finally
  4426.       FInitialized := False;
  4427.  
  4428.       SetOptions(FOptions);
  4429.  
  4430.       FViewport := nil;
  4431.       FCamera := nil;
  4432.       FScene := nil;
  4433.  
  4434.       FD3DRMDevice := nil;
  4435.       FD3DRMDevice2 := nil;
  4436.       FD3DDevice := nil;
  4437.       FD3DDevice2 := nil;
  4438.       FD3DDevice3 := nil;
  4439.       FD3D := nil;
  4440.       FD3D2 := nil;
  4441.       FD3D3 := nil;
  4442.  
  4443.       FreeZBufferSurface(FSurface, FZBuffer);
  4444.  
  4445.       FSurface.Free;   FSurface := nil;
  4446.  
  4447.       FD3DRM2 := nil;
  4448.       FD3DRM := nil;
  4449.     end;
  4450.   end;
  4451. end;
  4452.  
  4453. procedure TCustomDX3D.Initialize;
  4454. var
  4455.   ddsd: DDSURFACEDESC;
  4456.   AOptions: TInitializeDirect3DOptions;
  4457. begin
  4458.   Finalize;
  4459.   try
  4460.     FInitialized := True;
  4461.  
  4462.     {  Make surface.  }
  4463.     FillChar(ddsd, SizeOf(ddsd), 0);
  4464.     ddsd.dwSize := SizeOf(ddsd);
  4465.     ddsd.dwFlags := DDSD_WIDTH or DDSD_HEIGHT or DDSD_CAPS;
  4466.     ddsd.dwWidth := Max(FSurfaceWidth, 1);
  4467.     ddsd.dwHeight := Max(FSurfaceHeight, 1);
  4468.     ddsd.ddsCaps.dwCaps := DDSCAPS_OFFSCREENPLAIN or DDSCAPS_3DDEVICE;
  4469.     if toSystemMemory in FNowOptions then
  4470.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_SYSTEMMEMORY
  4471.     else
  4472.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps or DDSCAPS_VIDEOMEMORY;
  4473.  
  4474.     FSurface := TDirectDrawSurface.Create(FDXDraw.DDraw);
  4475.     if not FSurface.CreateSurface(ddsd) then
  4476.     begin
  4477.       ddsd.ddsCaps.dwCaps := ddsd.ddsCaps.dwCaps and (not DDSCAPS_VIDEOMEMORY) or DDSCAPS_SYSTEMMEMORY;
  4478.       if not FSurface.CreateSurface(ddsd) then
  4479.         raise EDX3DError.CreateFmt(SCannotMade, [SDirectDrawSurface]);
  4480.     end;
  4481.  
  4482.     AOptions := [];
  4483.  
  4484.     if toHardware in FNowOptions then AOptions := AOptions + [idoHardware];
  4485.     if toRetainedMode in FNowOptions then AOptions := AOptions + [idoRetainedMode];
  4486.     if toSelectDriver in FNowOptions then AOptions := AOptions + [idoSelectDriver];
  4487.     if toZBuffer in FNowOptions then AOptions := AOptions + [idoZBuffer];
  4488.     if toRGB in FNowOptions then AOptions := AOptions + [idoRGB];
  4489.     if toMono in FNowOptions then AOptions := AOptions + [idoMono];
  4490.     if toDither in FNowOptions then AOptions := AOptions + [idoDither];
  4491.  
  4492.     InitializeDirect3D(FSurface, FZBuffer, FD3D, FD3D2, FD3D3, FD3DDevice, FD3DDevice2, FD3DDevice3,
  4493.       FD3DRM, FD3DRM2, FD3DRMDevice, FD3DRMDevice2, FViewport, FScene, FCamera,
  4494.       FHWDeviceDesc, FHELDeviceDesc, FD3DDeviceDesc, AOptions);
  4495.  
  4496.     FNowOptions := [];
  4497.  
  4498.     if idoHardware in AOptions then FNowOptions := FNowOptions + [toHardware];
  4499.     if idoRetainedMode in AOptions then FNowOptions := FNowOptions + [toRetainedMode];
  4500.     if idoSelectDriver in AOptions then FNowOptions := FNowOptions + [toSelectDriver];
  4501.     if idoZBuffer in AOptions then FNowOptions := FNowOptions + [toZBuffer];
  4502.     if idoRGB in AOptions then FNowOptions := FNowOptions + [toRGB];
  4503.     if idoMono in AOptions then FNowOptions := FNowOptions + [toMono];
  4504.     if idoDither in AOptions then FNowOptions := FNowOptions + [toDither];
  4505.   except
  4506.     Finalize;
  4507.     raise;
  4508.   end;
  4509.  
  4510.   FInitFlag := True; DoInitialize;
  4511. end;
  4512.  
  4513. procedure TCustomDX3D.Render;
  4514. begin
  4515.   if FInitialized and (toRetainedMode in FNowOptions) then
  4516.   begin
  4517.     asm FInit end;
  4518.     FViewport.Clear;
  4519.     FViewport.Render(FScene);
  4520.     FD3DRMDevice.Update;
  4521.     asm FInit end;
  4522.   end;
  4523. end;
  4524.  
  4525. function TCustomDX3D.GetCanDraw: Boolean;
  4526. begin
  4527.   Result := Initialized and (Surface.IDDSurface<>nil) and
  4528.     (Surface.ISurface.IsLost=DD_OK);
  4529. end;
  4530.  
  4531. function TCustomDX3D.GetHardware: Boolean;
  4532. begin
  4533.   Result := Initialized and (toHardware in FNowOptions);
  4534. end;
  4535.  
  4536. function TCustomDX3D.GetSurfaceHeight: Integer;
  4537. begin
  4538.   if FSurface.IDDSurface<>nil then
  4539.     Result := FSurface.Height
  4540.   else
  4541.     Result := FSurfaceHeight;
  4542. end;
  4543.  
  4544. function TCustomDX3D.GetSurfaceWidth: Integer;
  4545. begin
  4546.   if FSurface.IDDSurface<>nil then
  4547.     Result := FSurface.Width
  4548.   else
  4549.     Result := FSurfaceWidth;
  4550. end;
  4551.  
  4552. procedure TCustomDX3D.SetAutoSize(Value: Boolean);
  4553. begin
  4554.   if FAutoSize<>Value then
  4555.   begin
  4556.     FAutoSize := Value;
  4557.     if FAutoSize and (DXDraw<>nil) then
  4558.       SetSize(DXDraw.SurfaceWidth, DXDraw.SurfaceHeight);
  4559.   end;
  4560. end;
  4561.  
  4562. procedure TCustomDX3D.SetOptions(Value: TDX3DOptions);
  4563. const
  4564.   DX3DOptions = [toSystemMemory, toHardware, toRetainedMode, toSelectDriver, toZBuffer,
  4565.     toRGB, toMono, toDither];
  4566.   InitOptions = [toSystemMemory, toHardware, toSelectDriver, toZBuffer,
  4567.     toRGB, toMono];
  4568. var
  4569.   OldOptions: TDX3DOptions;
  4570. begin
  4571.   FOptions := Value;
  4572.  
  4573.   if Initialized then
  4574.   begin
  4575.     OldOptions := FNowOptions;
  4576.     FNowOptions := FNowOptions*InitOptions+FOptions*(DX3DOptions - InitOptions);
  4577.  
  4578.     if ((FNowOptions-OldOptions)*[toDither]<>[]) or
  4579.       ((OldOptions-FNowOptions)*[toDither]<>[]) then
  4580.     begin
  4581.       if FD3DRMDevice<>nil then
  4582.       begin
  4583.        FD3DRMDevice.SetDither(toDither in FNowOptions);
  4584.       end else
  4585.       if FD3DDevice2<>nil then
  4586.       begin
  4587.         with FD3DDevice2 do
  4588.           SetRenderState(D3DRENDERSTATE_DITHERENABLE, Ord(toDither in FNowOptions));
  4589.       end;
  4590.     end;
  4591.   end else
  4592.   begin
  4593.     FNowOptions := FOptions;
  4594.   end;
  4595. end;
  4596.  
  4597. procedure TCustomDX3D.SetSize(ASurfaceWidth, ASurfaceHeight: Integer);
  4598. begin
  4599.   if (ASurfaceWidth<>SurfaceWidth) or (ASurfaceHeight<>SurfaceHeight) then
  4600.   begin
  4601.     FSurfaceWidth := ASurfaceWidth;
  4602.     FSurfaceHeight := ASurfaceHeight;
  4603.  
  4604.     if Initialized then
  4605.       Initialize;
  4606.   end;
  4607. end;
  4608.  
  4609. procedure TCustomDX3D.SetSurfaceHeight(Value: Integer);
  4610. begin
  4611.   if ComponentState*[csReading, csLoading]=[] then
  4612.     SetSize(SurfaceWidth, Value)
  4613.   else
  4614.     FSurfaceHeight := Value;
  4615. end;
  4616.  
  4617. procedure TCustomDX3D.SetSurfaceWidth(Value: Integer);
  4618. begin
  4619.   if ComponentState*[csReading, csLoading]=[] then
  4620.     SetSize(Value, SurfaceHeight)
  4621.   else
  4622.     FSurfaceWidth := Value;
  4623. end;
  4624.  
  4625. procedure TCustomDX3D.Notification(AComponent: TComponent;
  4626.   Operation: TOperation);
  4627. begin
  4628.   inherited Notification(AComponent, Operation);
  4629.   if (Operation=opRemove) and (FDXDraw=AComponent) then
  4630.     DXDraw := nil;
  4631. end;
  4632.  
  4633. procedure TCustomDX3D.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  4634.   NotifyType: TDXDrawNotifyType);
  4635. var
  4636.   AOptions: TInitializeDirect3DOptions;
  4637. begin
  4638.   case NotifyType of
  4639.     dxntDestroying:
  4640.         begin
  4641.           DXDraw := nil;
  4642.         end;
  4643.     dxntInitializing:
  4644.         begin                         
  4645.           if (FDXDraw.FOptions*[do3D, doFullScreen]=[doFullScreen])
  4646.             and (FOptions*[toSystemMemory, toSelectDriver]=[toSelectDriver]) then
  4647.           begin
  4648.             AOptions := [];
  4649.             with FDXDraw do
  4650.             begin
  4651.               if doHardware in Options then AOptions := AOptions + [idoHardware];
  4652.               if doRetainedMode in Options then AOptions := AOptions + [idoRetainedMode];
  4653.               if doSelectDriver in Options then AOptions := AOptions + [idoSelectDriver];
  4654.               if doZBuffer in Options then AOptions := AOptions + [idoZBuffer];
  4655.               if doRGB in Options then AOptions := AOptions + [idoRGB];
  4656.               if doMono in Options then AOptions := AOptions + [idoMono];
  4657.               if doDither in Options then AOptions := AOptions + [idoDither];
  4658.             end;
  4659.  
  4660.             Direct3DInitializing_DXDraw(AOptions, FDXDraw);
  4661.           end;
  4662.         end;
  4663.     dxntInitialize:
  4664.         begin
  4665.           Initialize;
  4666.         end;
  4667.     dxntFinalize:
  4668.         begin
  4669.           Finalize;
  4670.         end;
  4671.     dxntRestore:
  4672.         begin
  4673.           FSurface.Restore;
  4674.           if FZBuffer<>nil then
  4675.             FZBuffer.Restore;
  4676.           FSurface.Palette := FDXDraw.Palette;
  4677.         end;
  4678.     dxntSetSurfaceSize:
  4679.         begin
  4680.           if AutoSize then
  4681.             SetSize(Sender.SurfaceWidth, Sender.SurfaceHeight);
  4682.         end;
  4683.   end;
  4684. end;
  4685.  
  4686. procedure TCustomDX3D.SetDXDraw(Value: TCustomDXDraw);
  4687. begin
  4688.   if FDXDraw<>nil then
  4689.     FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  4690.  
  4691.   FDXDraw := Value;
  4692.  
  4693.   if FDXDraw<>nil then
  4694.     FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  4695. end;
  4696.  
  4697. {  TDirect3DTexture  }
  4698.  
  4699. constructor TDirect3DTexture.Create(Graphic: TGraphic; DXDraw: TComponent);
  4700. var
  4701.   i: Integer;
  4702. begin
  4703.   inherited Create;
  4704.   FDXDraw := DXDraw;
  4705.   FGraphic := Graphic;
  4706.  
  4707.   {  The palette is acquired.  }
  4708.   i := GetPaletteEntries(FGraphic.Palette, 0, 256, FPaletteEntries);
  4709.   case i of
  4710.     1..2   : FBitCount := 1;
  4711.     3..16  : FBitCount := 4;
  4712.     17..256: FBitCount := 8;
  4713.   else
  4714.     FBitCount := 24;
  4715.   end;
  4716.  
  4717.   if FDXDraw is TCustomDXDraw then
  4718.   begin
  4719.     with (FDXDraw as TCustomDXDraw) do
  4720.     begin
  4721.       if (not Initialized) or (not (do3D in NowOptions)) then
  4722.         raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
  4723.     end;
  4724.     FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDXDraw).Surface.DDraw);
  4725.     (FDXDraw as TCustomDXDraw).RegisterNotifyEvent(DXDrawNotifyEvent);
  4726.   end else if FDXDraw is TCustomDX3D then
  4727.   begin
  4728.     with (FDXDraw as TDX3D) do
  4729.     begin
  4730.       if not Initialized then
  4731.         raise EDirect3DTextureError.CreateFmt(SNotMade, [FDXDraw.ClassName]);
  4732.     end;
  4733.  
  4734.     FSurface := TDirectDrawSurface.Create((FDXDraw as TCustomDX3D).Surface.DDraw);
  4735.     (FDXDraw as TCustomDX3D).FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  4736.   end else
  4737.     raise EDirect3DTextureError.CreateFmt(SNotSupported, [FDXDraw.ClassName]);
  4738. end;
  4739.  
  4740. destructor TDirect3DTexture.Destroy;
  4741. begin
  4742.   if FDXDraw is TCustomDXDraw then
  4743.   begin
  4744.     (FDXDraw as TCustomDXDraw).UnRegisterNotifyEvent(DXDrawNotifyEvent);
  4745.   end else if FDXDraw is TCustomDX3D then
  4746.   begin
  4747.     (FDXDraw as TCustomDX3D).FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  4748.   end;
  4749.  
  4750.   Clear;
  4751.   FSurface.Free;
  4752.   inherited Destroy;
  4753. end;
  4754.  
  4755. procedure TDirect3DTexture.Clear;
  4756. begin
  4757.   FHandle := 0;
  4758.   FTexture := nil;
  4759.   FSurface.IDDSurface := nil;
  4760. end;
  4761.  
  4762. function TDirect3DTexture.GetHandle: D3DTEXTUREHANDLE;
  4763. begin
  4764.   if FTexture=nil then
  4765.     Restore;
  4766.   Result := FHandle;
  4767. end;
  4768.  
  4769. function TDirect3DTexture.GetSurface: TDirectDrawSurface;
  4770. begin
  4771.   if FTexture=nil then
  4772.     Restore;
  4773.   Result := FSurface;
  4774. end;
  4775.  
  4776. function TDirect3DTexture.GetTexture: IDirect3DTexture;
  4777. begin
  4778.   if FTexture=nil then
  4779.     Restore;
  4780.   Result := FTexture;
  4781. end;
  4782.  
  4783. procedure TDirect3DTexture.SetTransparentColor(Value: TColor);
  4784. begin
  4785.   if FTransparentColor<>Value then
  4786.   begin
  4787.     FTransparentColor := Value;
  4788.  
  4789.     if FSurface<>nil then
  4790.       FSurface.TransparentColor := FSurface.ColorMatch(Value);
  4791.   end;
  4792. end;
  4793.  
  4794. procedure TDirect3DTexture.Restore;
  4795.  
  4796.   function EnumTextureFormatCallback(const ddsd: DDSURFACEDESC;
  4797.     lParam: Pointer): HRESULT; stdcall;
  4798.   var
  4799.     tex: TDirect3DTexture;
  4800.  
  4801.     procedure UseThisFormat;
  4802.     begin
  4803.       tex.FFormat := ddsd;
  4804.       tex.FEnumFormatFlag := True;
  4805.     end;
  4806.  
  4807.   begin
  4808.     Result := DDENUMRET_OK;
  4809.     tex := lParam;
  4810.  
  4811.     if ddsd.ddpfPixelFormat.dwFlags and (DDPF_ALPHA or DDPF_ALPHAPIXELS)<>0 then
  4812.       Exit;
  4813.  
  4814.     if not tex.FEnumFormatFlag then
  4815.     begin
  4816.       {  When called first,  this format is unconditionally selected.  }
  4817.       UseThisFormat;
  4818.     end else
  4819.     begin
  4820.       if (tex.FBitCount<=8) and (ddsd.ddpfPixelFormat.dwRGBBitCount>=tex.FBitCount) and
  4821.         (ddsd.ddpfPixelFormat.dwRGBBitCount>=8) and
  4822.         (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB<>0) then
  4823.       begin
  4824.         if tex.FFormat.ddpfPixelFormat.dwRGBBitCount>ddsd.ddpfPixelFormat.dwRGBBitCount then
  4825.           UseThisFormat;
  4826.       end else
  4827.       begin
  4828.         if (tex.FFormat.ddpfPixelFormat.dwRGBBitCount>ddsd.ddpfPixelFormat.dwRGBBitCount) and
  4829.           (ddsd.ddpfPixelFormat.dwRGBBitCount>8) and
  4830.           (ddsd.ddpfPixelFormat.dwFlags and DDPF_RGB<>0) then
  4831.           UseThisFormat;
  4832.       end;
  4833.     end;
  4834.   end;
  4835.  
  4836.   function GetBitCount(i: Integer): Integer;
  4837.   var
  4838.     j: Integer;
  4839.   begin
  4840.     for j:=32 downto 1 do
  4841.       if (1 shl j) and i<>0 then
  4842.       begin
  4843.         Result := j;
  4844.         if 1 shl j<>i then
  4845.           Dec(Result);
  4846.         Exit;
  4847.       end;
  4848.     Result := 0;
  4849.   end;
  4850.  
  4851. var
  4852.   ddsd: DDSURFACEDESC;
  4853.   Palette: TDirectDrawPalette;
  4854.   PaletteCaps: Integer;
  4855.   Temp: TDirectDrawSurface;
  4856.   Width2, Height2: Integer;
  4857.   D3DDevice: IDirect3DDevice;
  4858.   Hardware: Boolean;
  4859.   DDraw: TDirectDraw;
  4860. begin
  4861.   Clear;
  4862.   try
  4863.     DDraw := nil;
  4864.     Hardware := False;
  4865.     if FDXDraw is TCustomDXDraw then
  4866.     begin
  4867.       DDraw := (FDXDraw as TCustomDXDraw).DDraw;
  4868.       D3DDevice := (FDXDraw as TCustomDXDraw).D3DDevice;
  4869.       Hardware := doHardware in (FDXDraw as TCustomDXDraw).NowOptions;
  4870.     end else if FDXDraw is TCustomDX3D then
  4871.     begin
  4872.       DDraw := (FDXDraw as TCustomDX3D).Surface.DDraw;
  4873.       D3DDevice := (FDXDraw as TCustomDX3D).D3DDevice;
  4874.       Hardware := toHardware in (FDXDraw as TCustomDX3D).NowOptions;
  4875.     end;
  4876.  
  4877.     if (DDraw=nil) or (D3DDevice=nil) then Exit;
  4878.  
  4879.     {  The size of texture is arranged in the size of the square of two.  }
  4880.     Width2 := Max(1 shl GetBitCount(FGraphic.Width), 1);
  4881.     Height2 := Max(1 shl GetBitCount(FGraphic.Height), 1);
  4882.  
  4883.     {  Selection of format of texture.  }
  4884.     FEnumFormatFlag := False;
  4885.     D3DDevice.EnumTextureFormats(@EnumTextureFormatCallback, Self);
  4886.  
  4887.     Temp := TDirectDrawSurface.Create(FSurface.DDraw);
  4888.     try
  4889.       {  Make source surface.  }
  4890.       with ddsd do
  4891.       begin
  4892.         dwSize := SizeOf(ddsd);
  4893.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  4894.         ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
  4895.         dwWidth := Width2;
  4896.         dwHeight := Height2;
  4897.         ddpfPixelFormat := FFormat.ddpfPixelFormat;
  4898.       end;
  4899.  
  4900.       if not Temp.CreateSurface(ddsd) then
  4901.         raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  4902.  
  4903.       {  Make surface.  }
  4904.       with ddsd do
  4905.       begin
  4906.         dwSize := SizeOf(ddsd);
  4907.         dwFlags := DDSD_CAPS or DDSD_HEIGHT or DDSD_WIDTH or DDSD_PIXELFORMAT;
  4908.         if Hardware then
  4909.           ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_VIDEOMEMORY
  4910.         else
  4911.           ddsCaps.dwCaps := DDSCAPS_TEXTURE or DDSCAPS_SYSTEMMEMORY;
  4912.         ddsCaps.dwCaps := ddsCaps.dwCaps or DDSCAPS_ALLOCONLOAD;
  4913.         dwWidth := Width2;
  4914.         dwHeight := Height2;
  4915.         ddpfPixelFormat := FFormat.ddpfPixelFormat;
  4916.       end;
  4917.  
  4918.       if not FSurface.CreateSurface(ddsd) then
  4919.         raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  4920.  
  4921.       {  Make palette.  }
  4922.       if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED8<>0 then
  4923.       begin
  4924.         PaletteCaps := DDPCAPS_8BIT or DDPCAPS_ALLOW256;
  4925.         if FBitCount=24 then
  4926.           CreateHalftonePalette(3, 3, 2);
  4927.       end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED4<>0 then
  4928.       begin
  4929.         PaletteCaps := DDPCAPS_4BIT;
  4930.         if FBitCount=24 then
  4931.           CreateHalftonePalette(1, 2, 1);
  4932.       end else if ddsd.ddpfPixelFormat.dwFlags and DDPF_PALETTEINDEXED1<>0 then
  4933.       begin
  4934.         PaletteCaps := DDPCAPS_1BIT;
  4935.         if FBitCount=24 then
  4936.         begin
  4937.           FPaletteEntries[0] := RGBQuadToPaletteEntry(RGBQuad(0, 0, 0));
  4938.           FPaletteEntries[1] := RGBQuadToPaletteEntry(RGBQuad(255, 255, 255));
  4939.         end;
  4940.       end else
  4941.         PaletteCaps := 0;
  4942.  
  4943.       if PaletteCaps<>0 then
  4944.       begin
  4945.         Palette := TDirectDrawPalette.Create(DDraw);
  4946.         try
  4947.           Palette.CreatePalette(PaletteCaps, FPaletteEntries);
  4948.           Temp.Palette := Palette;
  4949.           FSurface.Palette := Palette;
  4950.         finally
  4951.           Palette.Free;
  4952.         end;
  4953.       end;
  4954.  
  4955.       {  The image is loaded into source surface.  }
  4956.       with Temp.Canvas do
  4957.       begin
  4958.         StretchDraw(Temp.ClientRect, FGraphic);
  4959.         Release;
  4960.       end;
  4961.       {
  4962.       with FSurface.Canvas do
  4963.       begin
  4964.         StretchDraw(Temp.ClientRect, FGraphic);
  4965.         Release;
  4966.       end;
  4967.        }
  4968.       {  Source surface is loaded into surface.  }
  4969.       FTexture := FSurface.ISurface as IDirect3DTexture;
  4970.       FTexture.Load(Temp.ISurface as IDirect3DTexture);
  4971.     finally
  4972.       Temp.Free;
  4973.     end;
  4974.  
  4975.     if FTexture.GetHandle(D3DDevice, FHandle)<>D3D_OK then
  4976.       raise EDirect3DTextureError.CreateFmt(SCannotMade, [STexture]);
  4977.  
  4978.     FSurface.TransparentColor := FSurface.ColorMatch(FTransparentColor);
  4979.   except
  4980.     Clear;
  4981.     raise;
  4982.   end;
  4983. end;
  4984.  
  4985. procedure TDirect3DTexture.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  4986.   NotifyType: TDXDrawNotifyType);
  4987. begin
  4988.   case NotifyType of
  4989.     dxntInitializeSurface:
  4990.         begin
  4991.           Restore;
  4992.         end;
  4993.     dxntRestore:
  4994.         begin
  4995.           Restore;
  4996.         end;
  4997.   end;
  4998. end;
  4999.  
  5000. {  TDirect3DRMUserVisual  }
  5001.  
  5002. procedure TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK(lpD3DRMobj: IDirect3DRMObject;
  5003.   lpArg: Pointer); CDECL;
  5004. begin
  5005.   TDirect3DRMUserVisual(lpArg).Free;
  5006. end;
  5007.  
  5008. function TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK(lpD3DRMUV: IDirect3DRMUserVisual;
  5009.   lpArg: Pointer; lpD3DRMUVreason: D3DRMUSERVISUALREASON;
  5010.   lpD3DRMDev: IDirect3DRMDevice;
  5011.   lpD3DRMview: IDirect3DRMViewport): Integer; CDECL;
  5012. begin
  5013.   Result := TDirect3DRMUserVisual(lpArg).DoRender(lpD3DRMUVreason, lpD3DRMDev, lpD3DRMview);
  5014. end;
  5015.  
  5016. constructor TDirect3DRMUserVisual.Create(D3DRM: IDirect3DRM);
  5017. begin
  5018.   inherited Create;
  5019.  
  5020.   if D3DRM.CreateUserVisual(@TDirect3DRMUserVisual_D3DRMUSERVISUALCALLBACK,
  5021.     Self, FUserVisual)<>D3DRM_OK then
  5022.     raise EDirect3DRMUserVisualError.CreateFmt(SCannotMade, ['IDirect3DRMUserVisual']);
  5023.  
  5024.   FUserVisual.AddDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
  5025. end;
  5026.  
  5027. destructor TDirect3DRMUserVisual.Destroy;
  5028. begin
  5029.   if FUserVisual<>nil then
  5030.     FUserVisual.DeleteDestroyCallback(@TDirect3DRMUserVisual_D3DRMOBJECTCALLBACK, Self);
  5031.   FUserVisual := nil;
  5032.   inherited Destroy;
  5033. end;
  5034.  
  5035. function TDirect3DRMUserVisual.DoRender(Reason: D3DRMUSERVISUALREASON;
  5036.   D3DRMDev: IDirect3DRMDevice; D3DRMView: IDirect3DRMViewport): HRESULT;
  5037. begin
  5038.   Result := 0;
  5039. end;
  5040.  
  5041. {  TPictureCollectionItem  }
  5042.  
  5043. const
  5044.   SurfaceDivWidth = 512;
  5045.   SurfaceDivHeight = 512;
  5046.  
  5047. type
  5048.   TPictureCollectionItemPattern = class(TCollectionItem)
  5049.   private
  5050.     FRect: TRect;
  5051.     FSurface: TDirectDrawSurface;
  5052.   end;
  5053.  
  5054. constructor TPictureCollectionItem.Create(Collection: TCollection);
  5055. begin
  5056.   inherited Create(Collection);
  5057.   FPicture := TPicture.Create;
  5058.   FPatterns := TCollection.Create(TPictureCollectionItemPattern);
  5059.   FSurfaceList := TList.Create;
  5060.   FTransparent := True;
  5061. end;
  5062.  
  5063. destructor TPictureCollectionItem.Destroy;
  5064. begin
  5065.   Finalize;
  5066.   FPicture.Free;
  5067.   FPatterns.Free;
  5068.   FSurfaceList.Free;
  5069.   inherited Destroy;
  5070. end;
  5071.  
  5072. procedure TPictureCollectionItem.ClearSurface;
  5073. var
  5074.   i: Integer;
  5075. begin
  5076.   FPatterns.Clear;
  5077.   for i:=0 to FSurfaceList.Count-1 do
  5078.     TDirectDrawSurface(FSurfaceList[i]).Free;
  5079.   FSurfaceList.Clear;
  5080. end;
  5081.  
  5082. function TPictureCollectionItem.GetHeight: Integer;
  5083. begin
  5084.   Result := FPatternHeight;
  5085.   if (Result<=0) then
  5086.     Result := FPicture.Height;
  5087. end;
  5088.  
  5089. function TPictureCollectionItem.GetPictureCollection: TPictureCollection;
  5090. begin
  5091.   Result := Collection as TPictureCollection;
  5092. end;
  5093.  
  5094. function TPictureCollectionItem.GetPatternRect(Index: Integer): TRect;
  5095. begin
  5096.   if (Index>=0) and (index<FPatterns.Count) then
  5097.     Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FRect
  5098.   else
  5099.     Result := Rect(0, 0, 0, 0);
  5100. end;
  5101.  
  5102. function TPictureCollectionItem.GetPatternSurface(Index: Integer): TDirectDrawSurface;
  5103. begin
  5104.   if (Index>=0) and (index<FPatterns.Count) then
  5105.     Result := TPictureCollectionItemPattern(FPatterns.Items[Index]).FSurface
  5106.   else
  5107.     Result := nil;
  5108. end;
  5109.  
  5110. function TPictureCollectionItem.GetPatternCount: Integer;
  5111. begin
  5112.   if FSurfaceList.Count=0 then
  5113.     Result := (FPicture.Width div (PatternWidth+SkipWidth))*
  5114.       (FPicture.Height div (PatternHeight+SkipHeight))
  5115.   else
  5116.     Result := FPatterns.Count;
  5117. end;
  5118.  
  5119. function TPictureCollectionItem.GetWidth: Integer;
  5120. begin
  5121.   Result := FPatternWidth;
  5122.   if (Result<=0) then
  5123.     Result := FPicture.Width;
  5124. end;
  5125.                                        
  5126. procedure TPictureCollectionItem.Draw(Dest: TDirectDrawSurface; X, Y,
  5127.   PatternIndex: Integer);            
  5128. begin
  5129.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5130.   begin
  5131.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5132.       Dest.Draw(X, Y, FRect, FSurface, Transparent);
  5133.   end;                
  5134. end;
  5135.  
  5136. procedure TPictureCollectionItem.StretchDraw(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer);
  5137. begin
  5138.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5139.   begin
  5140.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5141.       Dest.StretchDraw(DestRect, FRect, FSurface, Transparent);
  5142.   end;
  5143. end;
  5144.  
  5145. procedure TPictureCollectionItem.DrawAdd(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  5146.   Alpha: Integer);
  5147. begin
  5148.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5149.   begin
  5150.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5151.       Dest.DrawAdd(DestRect, FRect, FSurface, Transparent, Alpha);
  5152.   end;
  5153. end;
  5154.  
  5155. procedure TPictureCollectionItem.DrawAlpha(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  5156.   Alpha: Integer);
  5157. begin
  5158.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5159.   begin
  5160.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5161.       Dest.DrawAlpha(DestRect, FRect, FSurface, Transparent, Alpha);
  5162.   end;
  5163. end;
  5164.  
  5165. procedure TPictureCollectionItem.DrawSub(Dest: TDirectDrawSurface; const DestRect: TRect; PatternIndex: Integer;
  5166.   Alpha: Integer);
  5167. begin
  5168.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5169.   begin
  5170.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5171.       Dest.DrawSub(DestRect, FRect, FSurface, Transparent, Alpha);
  5172.   end;
  5173. end;
  5174.  
  5175. procedure TPictureCollectionItem.DrawRotate(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5176.   CenterX, CenterY: Double; Angle: Integer);
  5177. begin
  5178.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5179.   begin
  5180.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5181.       Dest.DrawRotate(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle);
  5182.   end;
  5183. end;
  5184.  
  5185. procedure TPictureCollectionItem.DrawRotateAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5186.   CenterX, CenterY: Double; Angle, Alpha: Integer);
  5187. begin
  5188.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5189.   begin
  5190.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5191.       Dest.DrawRotateAdd(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  5192.   end;
  5193. end;
  5194.  
  5195. procedure TPictureCollectionItem.DrawRotateAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5196.   CenterX, CenterY: Double; Angle, Alpha: Integer);
  5197. begin
  5198.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5199.   begin
  5200.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5201.       Dest.DrawRotateAlpha(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  5202.   end;
  5203. end;
  5204.  
  5205. procedure TPictureCollectionItem.DrawRotateSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5206.   CenterX, CenterY: Double; Angle, Alpha: Integer);
  5207. begin
  5208.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5209.   begin
  5210.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5211.       Dest.DrawRotateSub(X, Y, Width, Height, FRect, FSurface, CenterX, CenterY, Transparent, Angle, Alpha);
  5212.   end;
  5213. end;
  5214.  
  5215. procedure TPictureCollectionItem.DrawWaveX(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5216.   amp, Len, ph: Integer);
  5217. begin
  5218.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5219.   begin
  5220.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5221.       Dest.DrawWaveX(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph);
  5222.   end;
  5223. end;
  5224.  
  5225. procedure TPictureCollectionItem.DrawWaveXAdd(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5226.   amp, Len, ph, Alpha: Integer);
  5227. begin
  5228.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5229.   begin
  5230.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5231.       Dest.DrawWaveXAdd(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  5232.   end;
  5233. end;
  5234.  
  5235. procedure TPictureCollectionItem.DrawWaveXAlpha(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5236.   amp, Len, ph, Alpha: Integer);
  5237. begin
  5238.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5239.   begin
  5240.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5241.       Dest.DrawWaveXAlpha(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  5242.   end;
  5243. end;
  5244.  
  5245. procedure TPictureCollectionItem.DrawWaveXSub(Dest: TDirectDrawSurface; X, Y, Width, Height, PatternIndex: Integer;
  5246.   amp, Len, ph, Alpha: Integer);
  5247. begin
  5248.   if FInitialized and (PatternIndex>=0) and (PatternIndex<FPatterns.Count) then
  5249.   begin
  5250.     with TPictureCollectionItemPattern(FPatterns.Items[PatternIndex]) do
  5251.       Dest.DrawWaveXSub(X, Y, Width, Height, FRect, FSurface, Transparent, amp, Len, ph, Alpha);
  5252.   end;
  5253. end;
  5254.  
  5255. procedure TPictureCollectionItem.Finalize;
  5256. begin
  5257.   if FInitialized then
  5258.   begin
  5259.     FInitialized := False;
  5260.     ClearSurface;
  5261.   end;
  5262. end;
  5263.  
  5264. procedure TPictureCollectionItem.Initialize;
  5265. begin
  5266.   Finalize;
  5267.   FInitialized := PictureCollection.Initialized;
  5268. end;
  5269.  
  5270. procedure TPictureCollectionItem.Restore;
  5271.  
  5272.   function AddSurface(const SrcRect: TRect): TDirectDrawSurface;
  5273.   begin
  5274.     Result := TDirectDrawSurface.Create(PictureCollection.DXDraw.DDraw);
  5275.     FSurfaceList.Add(Result);
  5276.  
  5277.     Result.SystemMemory := FSystemMemory;
  5278.     Result.LoadFromGraphicRect(FPicture.Graphic, 0, 0, SrcRect);
  5279.     Result.TransparentColor := Result.ColorMatch(FTransparentColor);
  5280.   end;
  5281.  
  5282. var
  5283.   x, y, x2, y2: Integer;
  5284.   BlockWidth, BlockHeight, BlockXCount, BlockYCount: Integer;
  5285.   Width2, Height2: Integer;
  5286. begin
  5287.   if not FInitialized then
  5288.   begin
  5289.     if PictureCollection.Initialized then
  5290.       Initialize;
  5291.     if not FInitialized then Exit;
  5292.   end;
  5293.  
  5294.   if FPicture.Graphic=nil then Exit;
  5295.  
  5296.   ClearSurface;
  5297.  
  5298.   Width2 := Width+SkipWidth;
  5299.   Height2 := Height+SkipHeight;
  5300.  
  5301.   if (Width=FPicture.Width) and (Height=FPicture.Height) then
  5302.   begin
  5303.     {  There is no necessity of division because the number of patterns is one.   }
  5304.     with TPictureCollectionItemPattern.Create(FPatterns) do
  5305.     begin
  5306.       FRect := Bounds(0, 0, FPicture.Width, FPicture.Height);
  5307.       FSurface := AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  5308.     end;
  5309.   end else if FSystemMemory then
  5310.   begin
  5311.     {  Load to a system memory.  }
  5312.     AddSurface(Bounds(0, 0, FPicture.Width, FPicture.Height));
  5313.  
  5314.     for y:=0 to (FPicture.Height+SkipHeight) div Height2-1 do
  5315.       for x:=0 to (FPicture.Width+SkipWidth) div Width2-1 do
  5316.         with TPictureCollectionItemPattern.Create(FPatterns) do
  5317.         begin
  5318.           FRect := Bounds(x * Width2, y * Height2, Width, Height);
  5319.           FSurface := TDirectDrawSurface(FSurfaceList[0]);
  5320.         end;
  5321.   end else
  5322.   begin
  5323.     {  Load to a video memory with dividing the image.   }
  5324.     BlockWidth := Min(((SurfaceDivWidth+Width2-1) div Width2)*Width2,
  5325.       (FPicture.Width+SkipWidth) div Width2*Width2);
  5326.     BlockHeight := Min(((SurfaceDivHeight+Height2-1) div Height2)*Height2,
  5327.       (FPicture.Height+SkipHeight) div Height2*Height2);
  5328.  
  5329.     BlockXCount := (FPicture.Width+BlockWidth-1) div BlockWidth;
  5330.     BlockYCount := (FPicture.Height+BlockHeight-1) div BlockHeight;
  5331.  
  5332.     if BlockXCount>1 then
  5333.       BlockXCount := BlockXCount;
  5334.  
  5335.     for y:=0 to BlockYCount-1 do
  5336.       for x:=0 to BlockXCount-1 do
  5337.       begin
  5338.         x2 := Min(BlockWidth, Max(FPicture.Width-x*BlockWidth, 0));
  5339.         if x2=0 then x2 := BlockWidth;
  5340.  
  5341.         y2 := Min(BlockHeight, Max(FPicture.Height-x*BlockHeight, 0));
  5342.         if y2=0 then y2 := BlockHeight;
  5343.  
  5344.         AddSurface(Bounds(x*BlockWidth, y*BlockHeight, x2, y2));
  5345.       end;
  5346.  
  5347.     for y:=0 to (FPicture.Height+SkipHeight) div Height2-1 do
  5348.       for x:=0 to (FPicture.Width+SkipWidth) div Width2-1 do
  5349.       begin
  5350.         x2 := x * Width2;
  5351.         y2 := y * Height2;
  5352.         with TPictureCollectionItemPattern.Create(FPatterns) do
  5353.         begin
  5354.           FRect := Bounds(x2-(x2 div BlockWidth*BlockWidth),
  5355.           y2-(y2 div BlockHeight*BlockHeight), Width, Height);
  5356.           FSurface := TDirectDrawSurface(FSurfaceList[(x2 div BlockWidth)+
  5357.             ((y div BlockHeight)*BlockXCount)]);
  5358.         end;
  5359.       end;
  5360.   end;
  5361. end;
  5362.  
  5363. procedure TPictureCollectionItem.SetPicture(Value: TPicture);
  5364. begin
  5365.   FPicture.Assign(Value);
  5366. end;
  5367.  
  5368. procedure TPictureCollectionItem.SetTransparentColor(Value: TColor);
  5369. var
  5370.   i: Integer;
  5371.   Surface: TDirectDrawSurface;
  5372. begin
  5373.   if Value<>FTransparentColor then
  5374.   begin
  5375.     for i:=0 to FSurfaceList.Count-1 do
  5376.     begin
  5377.       try
  5378.         Surface := TDirectDrawSurface(FSurfaceList[i]);
  5379.         Surface.TransparentColor := Surface.ColorMatch(FTransparentColor);
  5380.       except
  5381.       end;
  5382.     end;
  5383.     FTransparentColor := Value;
  5384.   end;
  5385. end;
  5386.  
  5387. {  TPictureCollection  }
  5388.  
  5389. constructor TPictureCollection.Create(AOwner: TPersistent);
  5390. begin
  5391.   inherited Create(TPictureCollectionItem);
  5392.   FOwner := AOwner;
  5393. end;
  5394.  
  5395. destructor TPictureCollection.Destroy;
  5396. begin
  5397.   Finalize;
  5398.   inherited Destroy;
  5399. end;
  5400.  
  5401. function TPictureCollection.GetItem(Index: Integer): TPictureCollectionItem;
  5402. begin
  5403.   Result := TPictureCollectionItem(inherited Items[Index]);
  5404. end;
  5405.  
  5406. function TPictureCollection.GetOwner: TPersistent;
  5407. begin
  5408.   Result := FOwner;
  5409. end;
  5410.  
  5411. function TPictureCollection.Find(const Name: string): TPictureCollectionItem;
  5412. var
  5413.   i: Integer;
  5414. begin
  5415.   i := IndexOf(Name);
  5416.   if i=-1 then
  5417.     raise EPictureCollectionError.CreateFmt(SImageNotFound, [Name]);
  5418.   Result := Items[i];
  5419. end;
  5420.  
  5421. procedure TPictureCollection.Finalize;
  5422. var
  5423.   i: Integer;
  5424. begin
  5425.   try
  5426.     for i:=0 to Count-1 do
  5427.       Items[i].Finalize;
  5428.   finally
  5429.     FDXDraw := nil;
  5430.   end;
  5431. end;
  5432.  
  5433. procedure TPictureCollection.Initialize(DXDraw: TCustomDXDraw);
  5434. var
  5435.   i: Integer;
  5436. begin
  5437.   Finalize;
  5438.   FDXDraw := DXDraw;
  5439.  
  5440.   if not Initialized then
  5441.     raise EPictureCollectionError.CreateFmt(SCannotInitialized, [ClassName]);
  5442.  
  5443.   for i:=0 to Count-1 do
  5444.     Items[i].Initialize;
  5445. end;
  5446.  
  5447. function TPictureCollection.Initialized: Boolean;
  5448. begin
  5449.   Result := (FDXDraw<>nil) and (FDXDraw.Initialized);
  5450. end;
  5451.  
  5452. procedure TPictureCollection.Restore;
  5453. var
  5454.   i: Integer;
  5455. begin
  5456.   for i:=0 to Count-1 do
  5457.     Items[i].Restore;
  5458. end;
  5459.  
  5460. procedure TPictureCollection.MakeColorTable;
  5461. var
  5462.   UseColorTable: array[0..255] of Boolean;
  5463.   PaletteCount: Integer;
  5464.  
  5465.   procedure SetColor(Index: Integer; Col: TRGBQuad);
  5466.   begin
  5467.     UseColorTable[Index] := True;
  5468.     ColorTable[Index] := Col;
  5469.     Inc(PaletteCount);
  5470.   end;
  5471.  
  5472.   procedure AddColor(Col: TRGBQuad);
  5473.   var
  5474.     i: Integer;
  5475.   begin
  5476.     for i:=0 to 255 do
  5477.       if UseColorTable[i] then
  5478.         if DWORD(ColorTable[i])=DWORD(Col) then
  5479.           Exit;
  5480.     for i:=0 to 255 do
  5481.       if not UseColorTable[i] then
  5482.       begin
  5483.         SetColor(i, Col);
  5484.         Exit;
  5485.       end;
  5486.   end;
  5487.  
  5488.   procedure AddDIB(DIB: TDIB);
  5489.   var
  5490.     x, y, i: Integer;
  5491.     UseFlag: array[0..255] of Boolean;
  5492.   begin
  5493.     if DIB.BitCount>8 then Exit;
  5494.  
  5495.     FillChar(UseFlag, SizeOf(UseFlag), 0);
  5496.     for y:=0 to DIB.Height-1 do
  5497.       for x:=0 to DIB.Width-1 do
  5498.         UseFlag[DIB.Pixels[x, y]] := True;
  5499.  
  5500.     for i:=0 to 255 do
  5501.       if UseFlag[i] then
  5502.         AddColor(DIB.ColorTable[i]);
  5503.   end;
  5504.  
  5505.   procedure AddGraphic(Graphic: TGraphic);
  5506.   var
  5507.     i, n: Integer;
  5508.     PaletteEntries: TPaletteEntries;
  5509.   begin
  5510.     if Graphic.Palette<>0 then
  5511.     begin
  5512.       n := GetPaletteEntries(Graphic.Palette, 0, 256, PaletteEntries);
  5513.       for i:=0 to n-1 do
  5514.         AddColor(PaletteEntryToRGBQuad(PaletteEntries[i]));
  5515.     end;
  5516.   end;
  5517.  
  5518. var
  5519.   i: Integer;
  5520. begin
  5521.   FillChar(UseColorTable, SizeOf(UseColorTable), 0);
  5522.   FillChar(ColorTable, SizeOf(ColorTable), 0);
  5523.  
  5524.   PaletteCount := 0;
  5525.  
  5526.   {  The system color is included.  }
  5527.   SetColor(0, RGBQuad(0, 0, 0));
  5528.   SetColor(1, RGBQuad(128, 0, 0));
  5529.   SetColor(2, RGBQuad(0, 128, 0));
  5530.   SetColor(3, RGBQuad(128, 128, 0));
  5531.   SetColor(4, RGBQuad(0, 0, 128));
  5532.   SetColor(5, RGBQuad(128, 0, 128));
  5533.   SetColor(6, RGBQuad(0, 128, 128));
  5534.   SetColor(7, RGBQuad(192, 192, 192));
  5535.  
  5536.   SetColor(248, RGBQuad(128, 128, 128));
  5537.   SetColor(249, RGBQuad(255, 0, 0));
  5538.   SetColor(250, RGBQuad(0, 255, 0));
  5539.   SetColor(251, RGBQuad(255, 255, 0));
  5540.   SetColor(252, RGBQuad(0, 0, 255));
  5541.   SetColor(253, RGBQuad(255, 0, 255));
  5542.   SetColor(254, RGBQuad(0, 255, 255));
  5543.   SetColor(255, RGBQuad(255, 255, 255));
  5544.  
  5545.   for i:=0 to Count-1 do
  5546.     if Items[i].Picture.Graphic<>nil then
  5547.     begin
  5548.       if Items[i].Picture.Graphic is TDIB then
  5549.         AddDIB(TDIB(Items[i].Picture.Graphic))
  5550.       else
  5551.         AddGraphic(Items[i].Picture.Graphic);
  5552.       if PaletteCount=256 then Break;
  5553.     end;
  5554. end;
  5555.  
  5556. procedure TPictureCollection.DefineProperties(Filer: TFiler);
  5557. begin
  5558.   inherited DefineProperties(Filer);
  5559.   Filer.DefineBinaryProperty('ColorTable', ReadColorTable, WriteColorTable, True);
  5560. end;
  5561.  
  5562. type
  5563.   TPictureCollectionComponent = class(TComponent)
  5564.   private
  5565.     FList: TPictureCollection;
  5566.   published
  5567.     property List: TPictureCollection read FList write FList;
  5568.   end;
  5569.  
  5570. procedure TPictureCollection.LoadFromFile(const FileName: string);
  5571. var
  5572.   Stream: TFileStream;
  5573. begin
  5574.   Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
  5575.   try
  5576.     LoadFromStream(Stream);
  5577.   finally
  5578.     Stream.Free;
  5579.   end;
  5580. end;
  5581.  
  5582. procedure TPictureCollection.LoadFromStream(Stream: TStream);
  5583. var
  5584.   Component: TPictureCollectionComponent;
  5585. begin
  5586.   Clear;
  5587.   Component := TPictureCollectionComponent.Create(nil);
  5588.   try
  5589.     Component.FList := Self;
  5590.     Stream.ReadComponentRes(Component);
  5591.  
  5592.     if Initialized then
  5593.     begin
  5594.       Initialize(FDXDraw);
  5595.       Restore;
  5596.     end;
  5597.   finally
  5598.     Component.Free;
  5599.   end;
  5600. end;
  5601.  
  5602. procedure TPictureCollection.SaveToFile(const FileName: string);
  5603. var
  5604.   Stream: TFileStream;
  5605. begin
  5606.   Stream := TFileStream.Create(FileName, fmCreate);
  5607.   try
  5608.     SaveToStream(Stream);
  5609.   finally
  5610.     Stream.Free;
  5611.   end;
  5612. end;
  5613.  
  5614. procedure TPictureCollection.SaveToStream(Stream: TStream);
  5615. var
  5616.   Component: TPictureCollectionComponent;
  5617. begin
  5618.   Component := TPictureCollectionComponent.Create(nil);
  5619.   try
  5620.     Component.FList := Self;
  5621.     Stream.WriteComponentRes('DelphiXPictureCollection', Component);
  5622.   finally
  5623.     Component.Free;
  5624.   end;
  5625. end;
  5626.  
  5627. procedure TPictureCollection.ReadColorTable(Stream: TStream);
  5628. begin
  5629.   Stream.ReadBuffer(ColorTable, SizeOf(ColorTable));
  5630. end;
  5631.  
  5632. procedure TPictureCollection.WriteColorTable(Stream: TStream);
  5633. begin
  5634.   Stream.WriteBuffer(ColorTable, SizeOf(ColorTable));
  5635. end;
  5636.  
  5637. {  TCustomDXImageList  }
  5638.  
  5639. constructor TCustomDXImageList.Create(AOnwer: TComponent);
  5640. begin
  5641.   inherited Create(AOnwer);
  5642.   FItems := TPictureCollection.Create(Self);
  5643. end;
  5644.  
  5645. destructor TCustomDXImageList.Destroy;
  5646. begin
  5647.   DXDraw := nil;
  5648.   FItems.Free;
  5649.   inherited Destroy;
  5650. end;
  5651.  
  5652. procedure TCustomDXImageList.Notification(AComponent: TComponent;
  5653.   Operation: TOperation);
  5654. begin
  5655.   inherited Notification(AComponent, Operation);
  5656.   if (Operation=opRemove) and (DXDraw=AComponent) then
  5657.     DXDraw := nil;
  5658. end;
  5659.  
  5660. procedure TCustomDXImageList.DXDrawNotifyEvent(Sender: TCustomDXDraw;
  5661.   NotifyType: TDXDrawNotifyType);
  5662. begin
  5663.   case NotifyType of
  5664.     dxntDestroying: DXDraw := nil;
  5665.     dxntInitialize: FItems.Initialize(Sender);
  5666.     dxntFinalize  : FItems.Finalize;
  5667.     dxntRestore   : FItems.Restore;
  5668.   end;
  5669. end;
  5670.  
  5671. procedure TCustomDXImageList.SetDXDraw(Value: TCustomDXDraw);
  5672. begin
  5673.   if FDXDraw<>nil then
  5674.     FDXDraw.UnRegisterNotifyEvent(DXDrawNotifyEvent);
  5675.  
  5676.   FDXDraw := Value;
  5677.  
  5678.   if FDXDraw<>nil then
  5679.     FDXDraw.RegisterNotifyEvent(DXDrawNotifyEvent);
  5680. end;
  5681.  
  5682. procedure TCustomDXImageList.SetItems(Value: TPictureCollection);
  5683. begin
  5684.   FItems.Assign(Value);
  5685. end;
  5686.  
  5687. initialization
  5688. finalization
  5689.   DirectDrawDrivers.Free;
  5690. end.
  5691.  
  5692.