www.pudn.com > DelphiX_for7.zip > DXClass.pas

unit DXClass; 
 
interface 
 
{$INCLUDE DelphiXcfg.inc} 
 
uses 
  Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, DirectX; 
 
type 
 
  {  EDirectDrawError  } 
 
  EDirectXError = class(Exception); 
 
  {  TDirectX  } 
 
  TDirectX = class(TPersistent) 
  private 
    procedure SetDXResult(Value: HRESULT); 
  protected 
    FDXResult: HRESULT; 
    procedure Check; virtual; 
  public 
    property DXResult: HRESULT read FDXResult write SetDXResult; 
  end; 
 
  {  TDirectXDriver  } 
 
  TDirectXDriver = class(TCollectionItem) 
  private 
    FGUID: PGUID; 
    FGUID2: TGUID; 
    FDescription: string; 
    FDriverName: string; 
    procedure SetGUID(Value: PGUID); 
  public 
    property GUID: PGUID read FGUID write SetGUID; 
    property Description: string read FDescription write FDescription; 
    property DriverName: string read FDriverName write FDriverName; 
  end; 
 
  {  TDirectXDrivers  } 
 
  TDirectXDrivers = class(TCollection) 
  private 
    function GetDriver(Index: Integer): TDirectXDriver; 
  public 
    constructor Create; 
    property Drivers[Index: Integer]: TDirectXDriver read GetDriver; default; 
  end; 
 
  {  TDXForm  } 
 
  TDXForm = class(TForm) 
  private 
    FStoreWindow: Boolean; 
    FWindowPlacement: TWindowPlacement; 
    procedure WMSYSCommand(var Msg: TWMSYSCommand); message WM_SYSCOMMAND; 
  protected 
    procedure CreateParams(var Params: TCreateParams); override; 
  public 
    constructor Create(AOnwer: TComponent); override; 
    destructor Destroy; override; 
    procedure RestoreWindow; 
    procedure StoreWindow; 
  end; 
 
  {  TCustomDXTimer  } 
 
  TDXTimerEvent = procedure(Sender: TObject; LagCount: Integer) of object; 
 
  TCustomDXTimer = class(TComponent) 
  private 
    FActiveOnly: Boolean; 
    FEnabled: Boolean; 
    FFrameRate: Integer; 
    FInitialized: Boolean; 
    FInterval: Cardinal; 
    FInterval2: Cardinal; 
    FNowFrameRate: Integer; 
    FOldTime: DWORD; 
    FOldTime2: DWORD; 
    FOnActivate: TNotifyEvent; 
    FOnDeactivate: TNotifyEvent; 
    FOnTimer: TDXTimerEvent; 
    procedure AppIdle(Sender: TObject; var Done: Boolean); 
    function AppProc(var Message: TMessage): Boolean; 
    procedure Finalize; 
    procedure Initialize; 
    procedure Resume; 
    procedure SetActiveOnly(Value: Boolean); 
    procedure SetEnabled(Value: Boolean); 
    procedure SetInterval(Value: Cardinal); 
    procedure Suspend; 
  protected 
    procedure DoActivate; virtual; 
    procedure DoDeactivate; virtual; 
    procedure DoTimer(LagCount: Integer); virtual; 
    procedure Loaded; override; 
  public 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
    property ActiveOnly: Boolean read FActiveOnly write SetActiveOnly; 
    property Enabled: Boolean read FEnabled write SetEnabled; 
    property FrameRate: Integer read FFrameRate; 
    property Interval: Cardinal read FInterval write SetInterval; 
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate; 
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate; 
    property OnTimer: TDXTimerEvent read FOnTimer write FOnTimer; 
  end; 
 
  {  TDXTimer  } 
 
  TDXTimer = class(TCustomDXTimer) 
  published 
    property ActiveOnly; 
    property Enabled; 
    property Interval; 
    property OnActivate; 
    property OnDeactivate; 
    property OnTimer; 
  end; 
 
  {  TControlSubClass  } 
 
  TControlSubClassProc = procedure(var Message: TMessage; DefWindowProc: TWndMethod) of object; 
 
  TControlSubClass = class 
  private 
    FControl: TControl; 
    FDefWindowProc: TWndMethod; 
    FWindowProc: TControlSubClassProc; 
    procedure WndProc(var Message: TMessage); 
  public 
    constructor Create(Control: TControl; WindowProc: TControlSubClassProc); 
    destructor Destroy; override; 
  end; 
 
  {  THashCollectionItem  } 
 
  THashCollectionItem = class(TCollectionItem) 
  private 
    FHashCode: Integer; 
    FIndex: Integer; 
    FName: string; 
    FLeft: THashCollectionItem; 
    FRight: THashCollectionItem; 
    procedure SetName(const Value: string); 
    procedure AddHash; 
    procedure DeleteHash; 
  protected 
    function GetDisplayName: string; override; 
    procedure SetIndex(Value: Integer); override; 
  public 
    constructor Create(Collection: TCollection); override; 
    destructor Destroy; override; 
    procedure Assign(Source: TPersistent); override; 
    property Index: Integer read FIndex write SetIndex; 
  published 
    property Name: string read FName write SetName; 
  end; 
 
  {  THashCollection  } 
 
  THashCollection = class(TCollection) 
  private 
    FHash: array[0..255] of THashCollectionItem; 
  public 
    function IndexOf(const Name: string): Integer; 
  end; 
 
function Max(Val1, Val2: Integer): Integer; 
function Min(Val1, Val2: Integer): Integer; 
 
function Cos256(i: Integer): Double; 
function Sin256(i: Integer): Double; 
 
function PointInRect(const Point: TPoint; const Rect: TRect): Boolean; 
function RectInRect(const Rect1, Rect2: TRect): Boolean; 
function OverlapRect(const Rect1, Rect2: TRect): Boolean; 
 
function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect; 
procedure ReleaseCom(out Com); 
function DXLoadLibrary(const FileName, FuncName: string): TFarProc; 
 
implementation 
 
uses DXConsts; 
 
function Max(Val1, Val2: Integer): Integer; 
begin 
  if Val1>=Val2 then Result := Val1 else Result := Val2; 
end; 
 
function Min(Val1, Val2: Integer): Integer; 
begin 
  if Val1<=Val2 then Result := Val1 else Result := Val2; 
end; 
 
function PointInRect(const Point: TPoint; const Rect: TRect): Boolean; 
begin 
  Result := (Point.X >= Rect.Left) and 
            (Point.X <= Rect.Right) and 
            (Point.Y >= Rect.Top) and 
            (Point.Y <= Rect.Bottom); 
end; 
 
function RectInRect(const Rect1, Rect2: TRect): Boolean; 
begin 
  Result := (Rect1.Left >= Rect2.Left) and 
            (Rect1.Right <= Rect2.Right) and 
            (Rect1.Top >= Rect2.Top) and 
            (Rect1.Bottom <= Rect2.Bottom); 
end; 
 
function OverlapRect(const Rect1, Rect2: TRect): Boolean; 
begin 
  Result := (Rect1.Left < Rect2.Right) and 
            (Rect1.Right > Rect2.Left) and 
            (Rect1.Top < Rect2.Bottom) and 
            (Rect1.Bottom > Rect2.Top); 
end; 
 
function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect; 
begin 
  with Result do 
  begin 
    Left := ALeft; 
    Top := ATop; 
    Right := ALeft+AWidth; 
    Bottom := ATop+AHeight; 
  end; 
end; 
 
var 
  CosinTable: array[0..255] of Double; 
 
procedure InitCosinTable; 
var 
  i: Integer; 
begin 
  for i:=0 to 255 do 
    CosinTable[i] := Cos((i/256)*2*PI); 
end; 
 
function Cos256(i: Integer): Double; 
begin 
  Result := CosinTable[i and 255]; 
end; 
 
function Sin256(i: Integer): Double; 
begin 
  Result := CosinTable[(i+192) and 255]; 
end; 
 
procedure ReleaseCom(out Com); 
begin 
end; 
 
var 
  LibList: TStringList; 
 
function DXLoadLibrary(const FileName, FuncName: string): Pointer; 
var 
  i: Integer; 
  h: THandle; 
begin 
  if LibList=nil then 
    LibList := TStringList.Create; 
 
  i := LibList.IndexOf(AnsiLowerCase(FileName)); 
  if i=-1 then 
  begin 
    {  DLL is loaded.  } 
    h := LoadLibrary(PChar(FileName)); 
    if h=0 then 
      raise Exception.CreateFmt(SDLLNotLoaded, [FileName]); 
    LibList.AddObject(AnsiLowerCase(FileName), Pointer(h)); 
  end else 
  begin 
    {  DLL has already been loaded.  } 
    h := THandle(LibList.Objects[i]); 
  end; 
 
  Result := GetProcAddress(h, PChar(FuncName)); 
  if Result=nil then 
    raise Exception.CreateFmt(SDLLNotLoaded, [FileName]); 
end; 
 
procedure FreeLibList; 
var 
  i: Integer; 
begin 
  if LibList<>nil then 
  begin 
    for i:=0 to LibList.Count-1 do 
      FreeLibrary(THandle(LibList.Objects[i])); 
    LibList.Free; 
  end; 
end; 
 
{  TDirectX  } 
 
procedure TDirectX.Check; 
begin 
end; 
 
procedure TDirectX.SetDXResult(Value: HRESULT); 
begin 
  FDXResult := Value; 
  if FDXResult<>0 then Check; 
end; 
 
{  TDirectXDriver  } 
 
procedure TDirectXDriver.SetGUID(Value: PGUID); 
begin 
  if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then 
  begin 
    FGUID2 := Value^; 
    FGUID := @FGUID2; 
  end else 
    FGUID := Value; 
end; 
 
{  TDirectXDrivers  } 
 
constructor TDirectXDrivers.Create; 
begin 
  inherited Create(TDirectXDriver); 
end; 
 
function TDirectXDrivers.GetDriver(Index: Integer): TDirectXDriver; 
begin 
  Result := (inherited Items[Index]) as TDirectXDriver; 
end; 
 
{  TDXForm  } 
 
var 
  SetAppExStyleCount: Integer; 
 
constructor TDXForm.Create(AOnwer: TComponent); 
var 
  ExStyle: Integer; 
begin 
  inherited Create(AOnwer); 
  Inc(SetAppExStyleCount); 
  ExStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE); 
  ExStyle := ExStyle or WS_EX_TOOLWINDOW; 
  SetWindowLong(Application.Handle, GWL_EXSTYLE, ExStyle); 
end; 
 
destructor TDXForm.Destroy; 
var 
  ExStyle: Integer; 
begin 
  Dec(SetAppExStyleCount); 
  if SetAppExStyleCount=0 then 
  begin 
    ExStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE); 
    ExStyle := ExStyle and (not WS_EX_TOOLWINDOW); 
    SetWindowLong(Application.Handle, GWL_EXSTYLE, ExStyle); 
  end; 
  inherited Destroy; 
end; 
 
procedure TDXForm.CreateParams(var Params: TCreateParams); 
begin 
  inherited CreateParams(Params); 
  Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW; 
end; 
 
procedure TDXForm.RestoreWindow; 
begin 
  if FStoreWindow then 
  begin 
    SetWindowPlacement(Handle, @FWindowPlacement); 
    FStoreWindow := False; 
  end; 
end; 
 
procedure TDXForm.StoreWindow; 
begin 
  FWindowPlacement.Length := SizeOf(FWindowPlacement); 
  FStoreWindow := GetWindowPlacement(Handle, @FWindowPlacement); 
end; 
 
procedure TDXForm.WMSYSCommand(var Msg: TWMSYSCommand); 
begin 
  if Msg.CmdType = SC_MINIMIZE then 
  begin 
    DefaultHandler(Msg); 
    WindowState := wsMinimized; 
  end else 
    inherited; 
end; 
 
{  TCustomDXTimer  } 
 
constructor TCustomDXTimer.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
  FActiveOnly := True; 
  FEnabled := True; 
  Interval := 1000; 
  Application.HookMainWindow(AppProc); 
end; 
 
destructor TCustomDXTimer.Destroy; 
begin 
  Finalize; 
  Application.UnHookMainWindow(AppProc); 
  inherited Destroy; 
end; 
 
procedure TCustomDXTimer.AppIdle(Sender: TObject; var Done: Boolean); 
var 
  t, t2: DWORD; 
  LagCount, i: Integer; 
begin 
  Done := False; 
 
  t := TimeGetTime; 
  t2 := t-FOldTime; 
  if t2>=FInterval then 
  begin 
    FOldTime := t; 
 
    LagCount := t2 div FInterval2; 
    if LagCount<1 then LagCount := 1; 
 
    Inc(FNowFrameRate); 
 
    i := Max(t-FOldTime2, 1); 
    if i>=1000 then 
    begin 
      FFrameRate := Round(FNowFrameRate*1000/i); 
      FNowFrameRate := 0; 
      FOldTime2 := t; 
    end; 
 
    DoTimer(LagCount); 
  end; 
end; 
 
function TCustomDXTimer.AppProc(var Message: TMessage): Boolean; 
begin 
  Result := False; 
  case Message.Msg of 
    CM_ACTIVATE: 
        begin 
          DoActivate; 
          if FInitialized and FActiveOnly then Resume; 
        end; 
    CM_DEACTIVATE: 
        begin 
          DoDeactivate; 
          if FInitialized and FActiveOnly then Suspend; 
        end; 
  end; 
end; 
 
procedure TCustomDXTimer.DoActivate; 
begin 
  if Assigned(FOnActivate) then FOnActivate(Self); 
end; 
 
procedure TCustomDXTimer.DoDeactivate; 
begin 
  if Assigned(FOnDeactivate) then FOnDeactivate(Self); 
end; 
 
procedure TCustomDXTimer.DoTimer(LagCount: Integer); 
begin 
  if Assigned(FOnTimer) then FOnTimer(Self, LagCount); 
end; 
 
procedure TCustomDXTimer.Finalize; 
begin 
  if FInitialized then 
  begin 
    Suspend; 
    FInitialized := False; 
  end; 
end; 
 
procedure TCustomDXTimer.Initialize; 
begin 
  Finalize; 
 
  if ActiveOnly then 
  begin 
    if Application.Active then 
      Resume; 
  end else 
    Resume; 
  FInitialized := True; 
end; 
 
procedure TCustomDXTimer.Loaded; 
begin 
  inherited Loaded; 
  if (not (csDesigning in ComponentState)) and FEnabled then 
    Initialize; 
end; 
 
procedure TCustomDXTimer.Resume; 
begin 
  FOldTime := TimeGetTime; 
  FOldTime2 := TimeGetTime; 
  Application.OnIdle := AppIdle; 
end; 
 
procedure TCustomDXTimer.SetActiveOnly(Value: Boolean); 
begin 
  if FActiveOnly<>Value then 
  begin 
    FActiveOnly := Value; 
 
    if Application.Active and FActiveOnly then 
      if FInitialized and FActiveOnly then Suspend; 
  end; 
end; 
 
procedure TCustomDXTimer.SetEnabled(Value: Boolean); 
begin 
  if FEnabled<>Value then 
  begin 
    FEnabled := Value; 
    if ComponentState*[csReading, csLoading]=[] then 
      if FEnabled then Initialize else Finalize; 
  end; 
end; 
 
procedure TCustomDXTimer.SetInterval(Value: Cardinal); 
begin 
  if FInterval<>Value then 
  begin 
    FInterval := Max(Value, 0); 
    FInterval2 := Max(Value, 1); 
  end; 
end; 
 
procedure TCustomDXTimer.Suspend; 
begin 
  Application.OnIdle := nil; 
end; 
 
{  TControlSubClass  } 
 
constructor TControlSubClass.Create(Control: TControl; 
  WindowProc: TControlSubClassProc); 
begin 
  inherited Create; 
  FControl := Control; 
  FDefWindowProc := FControl.WindowProc; 
  FControl.WindowProc := WndProc; 
  FWindowProc := WindowProc; 
end; 
 
destructor TControlSubClass.Destroy; 
begin 
  FControl.WindowProc := FDefWindowProc; 
  inherited Destroy; 
end; 
 
procedure TControlSubClass.WndProc(var Message: TMessage); 
begin 
  FWindowProc(Message, FDefWindowProc); 
end; 
 
{  THashCollectionItem  } 
 
function MakeHashCode(const Str: string): Integer; 
var 
  s: string; 
begin 
  s := AnsiLowerCase(Str); 
  Result := Length(s)*16; 
  if Length(s)>=2 then 
    Result := Result + (Ord(s[1]) + Ord(s[Length(s)-1])); 
  Result := Result and 255; 
end; 
                
constructor THashCollectionItem.Create(Collection: TCollection); 
begin 
  inherited Create(Collection); 
  FIndex := inherited Index; 
  AddHash; 
end; 
 
destructor THashCollectionItem.Destroy; 
var 
  i: Integer; 
begin 
  for i:=FIndex+1 to Collection.Count-1 do 
    Dec(THashCollectionItem(Collection.Items[i]).FIndex); 
  DeleteHash; 
  inherited Destroy; 
end; 
 
procedure THashCollectionItem.Assign(Source: TPersistent); 
begin 
  if Source is THashCollectionItem then 
  begin 
    Name := THashCollectionItem(Source).Name; 
  end else 
    inherited Assign(Source); 
end; 
 
procedure THashCollectionItem.AddHash; 
var 
  Item: THashCollectionItem; 
begin 
  FHashCode := MakeHashCode(FName); 
 
  Item := THashCollection(Collection).FHash[FHashCode]; 
  if Item<>nil then 
  begin 
    Item.FLeft := Self; 
    Self.FRight := Item; 
  end; 
 
  THashCollection(Collection).FHash[FHashCode] := Self; 
end; 
 
procedure THashCollectionItem.DeleteHash; 
begin 
  if FLeft<>nil then 
  begin 
    FLeft.FRight := FRight; 
    if FRight<>nil then 
      FRight.FLeft := FLeft; 
  end else 
  begin 
    if FHashCode<>-1 then 
    begin 
      THashCollection(Collection).FHash[FHashCode] := FRight; 
      if FRight<>nil then 
        FRight.FLeft := nil; 
    end; 
  end; 
  FLeft := nil; 
  FRight := nil; 
end; 
 
function THashCollectionItem.GetDisplayName: string; 
begin 
  Result := Name; 
  if Result='' then Result := inherited GetDisplayName; 
end; 
 
procedure THashCollectionItem.SetIndex(Value: Integer); 
begin 
  if FIndex<>Value then 
  begin 
    FIndex := Value; 
    inherited SetIndex(Value); 
  end; 
end; 
 
procedure THashCollectionItem.SetName(const Value: string); 
begin 
  if FName<>Value then 
  begin 
    FName := Value; 
    DeleteHash; 
    AddHash; 
  end; 
end; 
 
{  THashCollection  } 
 
function THashCollection.IndexOf(const Name: string): Integer; 
var 
  Item: THashCollectionItem; 
begin 
  Item := FHash[MakeHashCode(Name)]; 
  while Item<>nil do 
  begin 
    if AnsiCompareText(Item.Name, Name)=0 then 
    begin 
      Result := Item.FIndex; 
      Exit; 
    end; 
    Item := Item.FRight; 
  end; 
  Result := -1; 
end; 
 
initialization 
  InitCosinTable; 
finalization 
  FreeLibList; 
end.