Chip 2003 January/Chip_2003-01_cd1.bin/zkuste/delphi/unity/d56/FNDUTL.ZIP/System/cWindows.pas

Pascal/Delphi Source File | 2002-10-29 | 27.2 KB | 863 lines

{$INCLUDE ..\cDefines.inc}
unit cWindows;

{                                                                              }
{                          Windows functions v3.05                             }
{                                                                              }
{      This unit is copyright ⌐ 2000-2002 by David Butler ([e-mail])      }
{                                                                              }
{                  This unit is part of Delphi Fundamentals.                   }
{                    Its original file name is cWindows.pas                    }
{       The latest version is available from the Fundamentals home page        }
{                     http://fundementals.sourceforge.net/                     }
{                                                                              }
{                I invite you to use this unit, free of charge.                }
{        I invite you to distibute this unit, but it must be for free.         }
{             I also invite you to contribute to its development,              }
{             but do not distribute a modified copy of this file.              }
{                                                                              }
{          A forum is available on SourceForge for general discussion          }
{             http://sourceforge.net/forum/forum.php?forum_id=2117             }
{                                                                              }
{ Description:                                                                 }
{   MS Windows specific functions.                                             }
{                                                                              }
{ Revision history:                                                            }
{   2000/10/01  v1.01  Initial version spawned from cUtils.                    }
{   2001/12/12  v2.02  Added AWindowHandle.                                    }
{   2002/03/15  v2.03  Added GetWinOSType.                                     }
{   2002/06/26  v3.04  Refactored for Fundamentals 3.                          }
{   2002/09/22  v3.05  Moved Registry functions to unit cRegistry.             }
{                                                                              }

interface

uses
  // Delphi
  Windows,
  Messages,
  SysUtils,
  Classes,

  // Fundamentals
  cUtils;



{                                                                              }
{ Windows API                                                                  }
{                                                                              }
Function  GetWindowsTemporaryPath : String;
Function  GetWindowsPath : String;
Function  GetWindowsSystemPath : String;
Function  GetProgramFilesPath : String;
Function  GetApplicationPath : String;

Function  GetUserName : String;
Function  GetLocalComputerName : String;
Function  GetLocalHostName : String;

Function  GetEnvironmentStrings : StringArray;

Function  ContentTypeFromExtention (Extention : String) : String;

Function  IsApplicationAutoRun (const Name : String) : Boolean;
Procedure SetApplicationAutoRun (const Name : String; const AutoRun : Boolean);

Function  GetWinPortNames : StringArray;

Function  GetKeyPressed (const VKeyCode : Integer) : Boolean;

Function  WinExecute (const ExeName, Params : String;
          const ShowWin : Word = SW_SHOWNORMAL;
          const Wait : Boolean = True) : Boolean;

Function  GetHardDiskSerialNumber (const DriveLetter : Char) : String;
Function  GetWindowsProductID : String;

Function  GetMACAdresses (var Adresses : StringArray;
          const MachineName : String = '') : Integer;



{                                                                              }
{ Windows Version Info                                                         }
{                                                                              }
type
  TWinOSType = (win31,
                win32_95, win32_98, win32_ME,
                win32_NT, win32_2000, win32_XP,
                win_UnknownPlatform);

Function  GetWinOSType : TWinOSType;
Function  IsWinNTFamily : Boolean;
Function  IsWin95Family : Boolean;



{                                                                              }
{ Application Version Info                                                     }
{                                                                              }
type
  TVersionInfo = (viFileVersion, viFileDescription, viLegalCopyright,
                  viComments, viCompanyName, viInternalName,
                  viLegalTrademarks, viOriginalFilename, viProductName,
                  viProductVersion);

Function  GetAppVersionInfo (const VersionInfo : TVersionInfo) : String;



{                                                                              }
{ Window Handle                                                                }
{   Base class for allocation of a new Window handle that can process its own  }
{   messages.                                                                  }
{                                                                              }
type
  TWindowHandleMessageEvent = Function (const Msg : Cardinal; const wParam, lParam : Integer;
      var Handled : Boolean) : Integer of object;
  TWindowHandle = class;
  TWindowHandleErrorEvent = Procedure (const Sender : TWindowHandle;
      const E : Exception) of object;
  TWindowHandle = class (TComponent)
    protected
    FWindowHandle : HWND;
    FTerminated   : Boolean;
    FOnMessage    : TWindowHandleMessageEvent;
    FOnException  : TWindowHandleErrorEvent;

    Procedure RaiseError (const Msg : String);
    Function  AllocateWindowHandle : HWND; virtual;
    Function  HandleWM (const Msg : Cardinal; const wParam, lParam : Integer) : Integer; virtual;

    public
    Destructor Destroy; override;

    Procedure DestroyWindowHandle; virtual;
    Property  WindowHandle : HWND read FWindowHandle;
    Function  GetWindowHandle : HWND;

    Function  ProcessMessage : Boolean;
    Procedure ProcessMessages;
    Function  HandleMessage : Boolean;
    Procedure MessageLoop;

    Property  OnMessage : TWindowHandleMessageEvent read FOnMessage write FOnMessage;
    Property  OnException : TWindowHandleErrorEvent read FOnException write FOnException;

    Property  Terminated : Boolean read FTerminated;
    Procedure Terminate; virtual;
  end;
  EWindowHandle = class (Exception);

  { TfndWindowHandle                                                           }
  TfndWindowHandle = class (TWindowHandle)
    published
    Property  OnMessage;
    Property  OnException;
  end;



{                                                                              }
{ TTimerHandle                                                                 }
{                                                                              }
type
  TTimerHandle = class;
  TTimerEvent = Procedure (const Sender : TTimerHandle) of object;
  TTimerHandle = class (TWindowHandle)
    protected
    FTimerInterval : Integer;
    FTimerActive   : Boolean;
    FOnTimer       : TTimerEvent;

    Function  HandleWM (const Msg : Cardinal; const wParam, lParam : Integer) : Integer; override;
    Function  DoSetTimer : Boolean;
    Procedure TriggerTimer; virtual;
    Procedure SetTimerActive (const TimerActive : Boolean); virtual;
    Procedure Loaded; override;

    public
    Constructor Create (AOwner : TComponent); override;
    Procedure DestroyWindowHandle; override;

    Property  TimerInterval : Integer read FTimerInterval write FTimerInterval;
    Property  TimerActive : Boolean read FTimerActive write SetTimerActive;
    Property  OnTimer : TTimerEvent read FOnTimer write FOnTimer;
  end;

  { TfndTimerHandle                                                            }
  TfndTimerHandle = class (TTimerHandle)
    published
    Property  OnMessage;
    Property  OnException;
    Property  TimerInterval;
    Property  TimerActive;
    Property  OnTimer;
  end;



{$IFNDEF DELPHI6_UP}
{                                                                              }
{ RaiseLastOSError                                                             }
{                                                                              }
Procedure RaiseLastOSError;
{$ENDIF}



{                                                                              }
{ Component Register                                                           }
{                                                                              }
Procedure Register;



implementation

uses
  // Delphi
  WinSock,
  WinSpool,
  NB30,

  // Fundamentals
  cStrings,
  cRegistry;



{$IFNDEF DELPHI6_UP}
{                                                                              }
{ RaiseLastOSError                                                             }
{                                                                              }
Procedure RaiseLastOSError;
  Begin
    RaiseLastWin32Error;
  End;
{$ENDIF}



{                                                                              }
{ Windows API                                                                  }
{                                                                              }
Function GetWindowsTemporaryPath : String;
const MaxTempPathLen = MAX_PATH + 1;
var I : LongWord;
  Begin
    SetLength (Result, MaxTempPathLen);
    I := GetTempPath (MaxTempPathLen, PChar (Result));
    if I > 0 then
      SetLength (Result, I) else
      Result := '';
  End;

Function GetWindowsPath : String;
const MaxWinPathLen = MAX_PATH + 1;
var I : LongWord;
  Begin
    SetLength (Result, MaxWinPathLen);
    I := GetWindowsDirectory (PChar (Result), MaxWinPathLen);
    if I > 0 then
      SetLength (Result, I) else
      Result := '';
  End;

Function GetWindowsSystemPath : String;
const MaxWinSysPathLen = MAX_PATH + 1;
var I : LongWord;
  Begin
    SetLength (Result, MaxWinSysPathLen);
    I := GetSystemDirectory (PChar (Result), MaxWinSysPathLen);
    if I > 0 then
      SetLength (Result, I) else
      Result := '';
  End;

Function GetProgramFilesPath : String;
  Begin
    Result := GetRegistryString (HKEY_LOCAL_MACHINE,
           'Software\Microsoft\Windows\CurrentVersion', 'ProgramFilesDir');
  End;

Function GetApplicationPath : String;
  Begin
    Result := ExtractFilePath (ParamStr (0));
    EnsureSuffix (Result, '\');
  End;

Function GetUserName : String;
const MAX_USERNAME_LENGTH = 256;
var L : LongWord;
  Begin
    L := MAX_USERNAME_LENGTH + 2;
    SetLength (Result, L);
    if Windows.GetUserName (PChar (Result), L) and (L > 0) then
      SetLength (Result, StrLen (PChar (Result))) else
      Result := '';
  End;

Function GetLocalComputerName : String;
var L : LongWord;
  Begin
    L := MAX_COMPUTERNAME_LENGTH + 2;
    SetLength (Result, L);
    if Windows.GetComputerName (PChar (Result), L) and (L > 0) then
      SetLength (Result, StrLen (PChar (Result))) else
      Result := '';
  End;

Function GetLocalHostName : String;
const MAX_HOST_LENGTH = MAX_PATH;
var WSAData : TWSAData;
    L       : LongWord;
  Begin
    if WSAStartup ($0101, WSAData) = 0 then
      try
        L := MAX_HOST_LENGTH + 2;
        SetLengthAndZero (Result, L);
        if GetHostName (PChar (Result), L) = 0 then
          SetLength (Result, StrLen (PChar (Result))) else
          Result := '';
      finally
        WSACleanup;
      end;
  End;

Function GetEnvironmentStrings : StringArray;
var P, Q : PChar;
    I : Integer;
    S : String;
  Begin
    P := PChar (Windows.GetEnvironmentStrings);
    try
      if P^ <> #0 then
        Repeat
          Q := P;
          I := 0;
          While Q^ <> #0 do
            begin
              Inc (Q);
              Inc (I);
            end;
          SetLength (S, I);
          if I > 0 then
            Move (P^, Pointer (S)^, I);
          Append (Result, S);
          P := Q;
          Inc (P);
        Until P^ = #0;
    finally
      FreeEnvironmentStrings (P);
    end;
  End;

Function ContentTypeFromExtention (Extention : String) : String;
  Begin
    Result := GetRegistryString (HKEY_CLASSES_ROOT, '\' + Extention, 'Content Type');
  End;

const
  AutoRunRegistryKey = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Run';

Function  IsApplicationAutoRun (const Name : String) : Boolean;
var S : String;
  Begin
    S := ParamStr (0);
    Result := (S <> '') and (Name <> '') and
        IsEqualNoCase (GetRegistryString (HKEY_LOCAL_MACHINE, AutoRunRegistryKey, Name), S);
  End;

Procedure SetApplicationAutoRun (const Name : String; const AutoRun : Boolean);
  Begin
    if Name = '' then
      exit;
    if AutoRun then
      SetRegistryString (HKEY_LOCAL_MACHINE, AutoRunRegistryKey, Name, ParamStr (0)) else
      DeleteRegistryValue (HKEY_LOCAL_MACHINE, AutoRunRegistryKey, Name);
  End;

Function GetWinPortNames : StringArray;
var BytesNeeded, N, I : LongWord;
    Buf : Pointer;
    InfoPtr : PPortInfo1;
    TempStr : String;
  Begin
    Result := nil;
    if EnumPorts (nil, 1, nil, 0, BytesNeeded, N) then
      exit;
    if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
      RaiseLastOSError;

    GetMem (Buf, BytesNeeded);
    try
      if not EnumPorts (nil, 1, Buf, BytesNeeded, BytesNeeded, N) then
        RaiseLastOSError;
      For I := 0 to N - 1 do
        begin
          InfoPtr := PPortInfo1 (LongWord (Buf) + I * SizeOf (TPortInfo1));
          TempStr := InfoPtr^.pName;
          Append (Result, TempStr);
        end;
    finally
      FreeMem(Buf);
    end;
  End;

Function GetKeyPressed (const VKeyCode : Integer) : Boolean;
  Begin
    Result := GetKeyState (VKeyCode) and $80 <> 0;
  End;



{                                                                              }
{ Windows Version Info                                                         }
{                                                                              }
Function GetWinOSType : TWinOSType;
  Begin
    Case Win32Platform of
      VER_PLATFORM_WIN32s :
        Result := win31;
      VER_PLATFORM_WIN32_WINDOWS :
        begin
          Result := win32_95;
          if Win32MajorVersion = 4 then
            if Win32MinorVersion >= 90 then
              Result := win32_ME else
            if Win32MinorVersion >= 10 then
              Result := win32_98;
        end;
      VER_PLATFORM_WIN32_NT :
        begin
          Result := win32_nt;
          if Win32MajorVersion = 5 then
            if Win32MinorVersion >= 1 then
              Result := win32_xp else
              Result := win32_2000;
        end;
    else
      Result := win_UnknownPlatform;
    end;
  End;

Function IsWinNTFamily : Boolean;
  Begin
    Result := Win32Platform = VER_PLATFORM_WIN32_NT;
  End;

Function IsWin95Family : Boolean;
  Begin
    Result := Win32Platform = VER_PLATFORM_WIN32_WINDOWS;
  End;



{                                                                              }
{ Application Version Info                                                     }
{                                                                              }
var
  VersionInfoBuf : Pointer = nil;
  VerTransStr    : String;

Procedure LoadAppVersionInfo;
type TTransBuffer = Array [1..4] of SmallInt;
     PTransBuffer = ^TTransBuffer;
var InfoSize : Integer;
    Size, H : LongWord;
    EXEName : String;
    Trans : PTransBuffer;
  Begin
    if Assigned (VersionInfoBuf) then
      exit;
    EXEName := ParamStr (0);
    InfoSize := GetFileVersionInfoSize (PChar (EXEName), H);
    if InfoSize = 0 then
      exit;
    GetMem (VersionInfoBuf, InfoSize);
    if not GetFileVersionInfo (PChar (EXEName), H, InfoSize, VersionInfoBuf) then
      begin
        FreeMem (VersionInfoBuf);
        VersionInfoBuf := nil;
        exit;
      end;
    VerQueryValue (VersionInfoBuf, PChar ('\VarFileInfo\Translation'),
                   Pointer (Trans), Size);
    VerTransStr := IntToHex (Trans^ [1], 4) + IntToHex (Trans^ [2], 4);
  End;

const
  VersionInfoStr : Array [TVersionInfo] of String =
    ('FileVersion', 'FileDescription', 'LegalCopyright', 'Comments',
     'CompanyName', 'InternalName', 'LegalTrademarks',
     'OriginalFilename', 'ProductName', 'ProductVersion');

Function GetAppVersionInfo (const VersionInfo : TVersionInfo) : String;
var S : String;
    Size : LongWord;
    Value : PChar;
  Begin
    LoadAppVersionInfo;
    S := 'StringFileInfo\' + VerTransStr + '\' + VersionInfoStr [VersionInfo];
    if not VerQueryvalue (VersionInfoBuf, PChar (S), Pointer (Value), Size) then
      Result := '' else
      Result := Value;
  End;

Function WinExecute (const ExeName, Params : String; const ShowWin : Word; const Wait : Boolean) : Boolean;
var StartUpInfo : TStartupInfo;
    ProcessInfo    : TProcessInformation;
    Cmd         : String;
  Begin
    if Params = '' then
      Cmd := ExeName else
      Cmd := ExeName + ' ' + Params;
    FillChar (StartUpInfo, SizeOf (StartUpInfo), #0);
    StartUpInfo.cb := SizeOf (StartUpInfo);
    StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
    StartUpInfo.wShowWindow := ShowWin;
    Result := CreateProcess(
             nil, PChar (Cmd), nil, nil, False,
             CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil,
             PChar (ExtractFilePath (ExeName)), StartUpInfo, ProcessInfo);
    if Wait then
      WaitForSingleObject (ProcessInfo.hProcess, INFINITE);
  End;

Function GetHardDiskSerialNumber (const DriveLetter : Char) : String;
var N, F, S : DWORD;
  Begin
    S := 0;
    GetVolumeInformation (PChar (DriveLetter + ':\'), nil, MAX_PATH + 1, @S,
        N, F, nil, 0);
    Result := LongWordToHex (S, 8);
  End;

Function GetWindowsProductID : String;
var S : String;
  Begin
    if IsWinNTFamily then
      S := 'Software\Microsoft\Windows NT\CurrentVersion' else
      S := 'Software\Microsoft\Windows\CurrentVersion';
    Result := GetRegistryString (HKEY_LOCAL_MACHINE, S, 'ProductID');
  End;

Function GetMACAdresses (var Adresses : StringArray; const MachineName : String) : Integer;

  Function NetBiosCheck (const B : Char) : Boolean;
    Begin
      Result := B = Char (NRC_GOODRET);
    End;

  Procedure MachineNameToAdapter (const Name : String; var AdapterName : Array of char);
  var S : String;
    Begin
      if Name = '' then
        S := '*' else
        S := UpperCase (Name);
      FillChar (AdapterName, Length (AdapterName), #0);
      Move (Pointer (S)^, AdapterName [0], Length (S));
    End;

  Function AdapterToString (const Adapter : PAdapterStatus) : String;
  var I : Integer;
    Begin
      Result := '';
      With Adapter^ do
        For I := 0 to 5 do
          Result := Result + LongWordToHex (Ord (adapter_address [I]), 2);
  end;

var I : Integer;
    NCB : TNCB;
    Adapter : TAdapterStatus;
    Lenum : TLanaEnum;
    RetCode:char;
  Begin
    Adresses := nil;
    FillChar (NCB, SizeOf (TNCB), #0);
    FillChar (Lenum, SizeOf (TLanaEnum), #0);
    NCB.ncb_command := char (NCBENUM);
    NCB.ncb_buffer := @Lenum;
    NCB.ncb_length := SizeOf (Pointer);
    if not NetBiosCheck (Netbios (@NCB)) then
      begin
        Result := 0;
        exit;
      end;
    Result := Ord (Lenum.Length);
    for i := 0 to Result - 1 do
      begin
        FillChar (NCB, SizeOf (TNCB), #0);
        Ncb.ncb_command := Char (NCBRESET);
        Ncb.ncb_lana_num := lenum.lana [i];
        if NetBiosCheck (Netbios (@NCB)) then
          begin
            FillChar (NCB, SizeOf (TNCB), #0);
            FillChar (Adapter, SizeOf (TAdapterStatus), #0);
            Ncb.ncb_command := Char (NCBASTAT);
            Ncb.ncb_lana_num := lenum.lana [i];
            MachineNameToAdapter (MachineName, Ncb.ncb_callname);
            Ncb.ncb_buffer := @Adapter;
            Ncb.ncb_length := SizeOf (TAdapterStatus);
            RetCode := Netbios (@NCB);
            if RetCode in [Char (NRC_GOODRET), Char (NRC_INCOMP)] then
              Append (Adresses, AdapterToString (@Adapter));
          end;
      end;
  End;



{                                                                              }
{ TWindowHandle                                                                }
{                                                                              }
Function WindowHandleMessageProc (const WindowHandle : HWND; const Msg : Cardinal;
    const wParam, lParam : Integer) : Integer; stdcall;
var V : TObject;
  Begin
    V := TObject (GetWindowLong (WindowHandle, 0)); // Get user data
    if V is TWindowHandle then
      Result := TWindowHandle (V).HandleWM (Msg, wParam, lParam) else
      Result := DefWindowProc (WindowHandle, Msg, wParam, lParam); // Default handler
  End;

var
  WindowClass : TWndClass = (
      style         : 0;
      lpfnWndProc   : @WindowHandleMessageProc;
      cbClsExtra    : 0;
      cbWndExtra    : SizeOf (Pointer); // Size of extra user data
      hInstance     : 0;
      hIcon         : 0;
      hCursor       : 0;
      hbrBackground : 0;
      lpszMenuName  : nil;
      lpszClassName : 'FundamentalsWindowClass');

Destructor TWindowHandle.Destroy;
  Begin
    DestroyWindowHandle;
    inherited Destroy;
  End;

Procedure TWindowHandle.RaiseError (const Msg : String);
  Begin
    raise EWindowHandle.Create (Msg);
  End;

Function TWindowHandle.AllocateWindowHandle : HWND;
var C : TWndClass;
  Begin
    WindowClass.hInstance := HInstance;
    // Register class
    if not GetClassInfo (HInstance, WindowClass.lpszClassName, C) then
      if Windows.RegisterClass (WindowClass) = 0 then
        RaiseError ('Window class registration failed: Windows error #' + IntToStr (GetLastError));

    // Allocate handle
    Result := CreateWindowEx (WS_EX_TOOLWINDOW,
                              WindowClass.lpszClassName,
                              '',        { Window name   }
                              WS_POPUP,  { Window Style  }
                              0, 0,      { X, Y          }
                              0, 0,      { Width, Height }
                              0,         { hWndParent    }
                              0,         { hMenu         }
                              HInstance, { hInstance     }
                              nil);      { CreateParam   }
    if Result = 0 then
      RaiseError ('Window handle allocation failed: Windows error #' + IntToStr (GetLastError));

    // Set user data
    SetWindowLong (Result, 0, Integer (self));
  End;

Function TWindowHandle.HandleWM (const Msg : Cardinal; const wParam, lParam : Integer) : Integer;
var Handled : Boolean;
  Begin
    Result := 0;
    Handled := False;
    try
      if Assigned (FOnMessage) then
        Result := FOnMessage (Msg, wParam, lParam, Handled);
      if not Handled then
        Result := DefWindowProc (FWindowHandle, Msg, wParam, lParam); // Default handler
    except
      on E : Exception do
        begin
          if Assigned (FOnException) then
            FOnException (self, E);
          exit;
        end;
    end;
  End;

Function TWindowHandle.GetWindowHandle : HWND;
  Begin
    Result := FWindowHandle;
    if Result = 0 then
      begin
        FWindowHandle := AllocateWindowHandle;
        Result := FWindowHandle;
      end;
  End;

Procedure TWindowHandle.DestroyWindowHandle;
  Begin
    if FWindowHandle = 0 then
      exit;

    // Clear user data
    SetWindowLong (FWindowHandle, 0, 0);

    DestroyWindow (FWindowHandle);
    FWindowHandle := 0;
  End;

Function TWindowHandle.ProcessMessage : Boolean;
var Msg : TMsg;
  Begin
    if FTerminated then
      begin
        Result := False;
        exit;
      end;
    Result := PeekMessage (Msg, 0, 0, 0, PM_REMOVE);
    if Result then
      if Msg.Message = WM_QUIT then
        FTerminated := True else
        if FTerminated then
          Result := False else
          begin
            TranslateMessage (Msg);
            DispatchMessage (Msg);
          end;
  End;

Procedure TWindowHandle.ProcessMessages;
  Begin
    While ProcessMessage do ;
  End;

Function TWindowHandle.HandleMessage : Boolean;
var Msg : TMsg;
  Begin
    if FTerminated then
      begin
        Result := False;
        exit;
      end;
    Result := GetMessage (Msg, 0, 0, 0);
    if not Result then
      FTerminated := True else
      if FTerminated then
        Result := False else
        begin
          TranslateMessage (Msg);
          DispatchMessage (Msg)
        end;
  End;

Procedure TWindowHandle.MessageLoop;
  Begin
    While HandleMessage do ;
  End;

Procedure TWindowHandle.Terminate;
  Begin
    FTerminated := True;
  End;



{                                                                              }
{ TTimerHandle                                                                 }
{                                                                              }
Constructor TTimerHandle.Create (AOwner : TComponent);
  Begin
    inherited Create (AOwner);
    FTimerInterval := 1000;
  End;

Procedure TTimerHandle.DestroyWindowHandle;
  Begin
    if not (csDesigning in ComponentState) and (FWindowHandle <> 0) and
        FTimerActive then
      KillTimer (FWindowHandle, 1);
    inherited DestroyWindowHandle;
  End;

Function TTimerHandle.DoSetTimer : Boolean;
  Begin
    if FTimerInterval <= 0 then
      Result := False else
      Result := SetTimer (GetWindowHandle, 1, FTimerInterval, nil) = 0;
  End;

Procedure TTimerHandle.Loaded;
  Begin
    inherited Loaded;
    if not (csDesigning in ComponentState) and FTimerActive then
      DoSetTimer;
  End;

Procedure TTimerHandle.TriggerTimer;
  Begin
    if Assigned (FOnTimer) then
      FOnTimer (self);
  End;

Procedure TTimerHandle.SetTimerActive (const TimerActive : Boolean);
  Begin
    if FTimerActive = TimerActive then
      exit;
    if [csDesigning, csLoading] * ComponentState = [] then
      if TimerActive then
        begin
          if not DoSetTimer then
            exit;
        end else
        KillTimer (FWindowHandle, 1);
    FTimerActive := TimerActive;
  End;

Function TTimerHandle.HandleWM (const Msg : Cardinal; const wParam, lParam : Integer) : Integer;
  Begin
    if Msg = WM_TIMER then
      try
        Result := 0;
        TriggerTimer;
      except
        on E : Exception do
          begin
            Result := 0;
            if Assigned (FOnException) then
              FOnException (self, E);
            exit;
          end;
      end else
      Result := inherited HandleWM (Msg, wParam, lParam);
  End;



{                                                                              }
{ Component Register                                                           }
{                                                                              }
Procedure Register;
  Begin
    RegisterComponents ('Fundamentals', [TfndWindowHandle, TfndTimerHandle]);
  End;



initialization
finalization
  if Assigned (VersionInfoBuf) then
    FreeMem (VersionInfoBuf);
end.