Delphi控件源码

开发平台：
Delphi

MMUtils.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 10.01.99 - 02:42:37 $                                        =}
{========================================================================}
unit MMUtils;
{$I COMPILER.INC}
interface
{.$DEFINE _MMDEBUG_}
uses
    {$IFDEF WIN32}
    Windows,
    Registry,
    {$ELSE}
    WinTypes,
    WinProcs,
    {$ENDIF}
    {$IFDEF DELPHI6}
    Variants,
    {$ENDIF}
    Messages,
    SysUtils,
    Controls,
    Classes,
    Forms,
    FileCtrl,
    Dialogs,
    Graphics
    {$IFDEF BUILD_ACTIVEX}
    ,MMAbout
    {$ENDIF}
    ;
{$I MMTYPES.INC}
{$IFDEF BUILD_ACTIVEX}
   {$I MMREGCODES.INC}
{$ENDIF}
const
    InstalledUser  : string  = '*UI:*******************************************************************************';
    InitCode       : Longint = 0;
    ErrorCode      : Longint = 0;
    SHandle        : integer = 0;
    IValue         : integer = 0;
    DValue         : integer = 0;
    SBuf           : PChar   = nil;
    MMUTILDLLHandle: THandle = 0;
var
    SValue        : string;
    _Win95_       : Boolean;
    _Win98_       : Boolean;
    _WinME_       : Boolean;
    _Win9x_       : Boolean;
    _WinNT3_      : Boolean;
    _WinNT4_      : Boolean;
    _Win2K_       : Boolean;
    _WinXP_       : Boolean;
    _WinNT_       : Boolean;
    _WinNT_NEW_   : Boolean;
    _CPU_         : integer;
    _MMX_         : Boolean;
    _USECPUEXT_   : Boolean;
{$IFDEF USEDLL}
const
{$IFDEF WIN32}
   MMUtilDLLName    = 'MMUTIL32.DLL'#0;//'MMUTIL32.DLL'#0;
   MMUtilDLLKeyName = 'MMKEY32.DLL'#0;
{$ELSE}
   MMUtilDLLName    = 'MMUTIL16.DLL'#0;
   MMUtilDLLKeyName = 'MMKEY16.DLL'#0;
{$ENDIF}
{$ENDIF}
const
    { Processor constants }
    PENTIUM    = 1;
    PENTIUMPRO = 2;
    PENTIUMPRO2= 3;
    MMAXLONG   = 2000000000;
    {$IFDEF WIN32}
    MM_USER    = WM_APP;
    {$ELSE}
    MM_USER    = WM_USER;
    {$ENDIF}
    MM_TIMER   = MM_USER + 10;
{$IFNDEF WIN32}
    MAX_PATH   = 260;
    cl3DLight  = clBtnFace;
procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
{$ELSE}
function  MMSetThreadPriority(hThread: THandle; nPriority: integer): Boolean;
function  MMSetPriorityClass(hProcess: THandle; fdwPriority: DWORD): Boolean;
function  GetFromRegistry(_RootKey:HKEY;_Localkey,_Field:string;Value:Variant): Variant;
procedure SaveInRegistry(_RootKey:HKEY;_Localkey,_Field:string;Value:Variant);
function  GetFromRegistryBinary(_RootKey:HKEY;_Localkey,_Field:string;var Buffer; BufSize: integer): integer;
procedure SaveInRegistryBinary(_RootKey:HKEY;_Localkey,_Field:string;var Buffer; BufSize: integer);
function  GetCPUUsage: integer;
function  GetShortFileName(Name: TFileName): String;
function  GetCPUType: integer;
function  GetCPUFeatures: Longint;
function  GetCPUMode: integer;
function  GetCPUCycles: int64;
procedure InitTimeMeasure;
procedure StartTimeMeasure;
function  StopTimeMeasure(Scale: integer): string;
procedure InitCyclesMeasure;
procedure StartCyclesMeasure;
function  StopCyclesMeasure(Scale: integer): string;
{$ENDIF}
function  HaveWin95: Boolean;
function  HaveWin98: Boolean;
function  HaveWinME: Boolean;
function  HaveWinNT: Boolean;
function  HaveWinNT4: Boolean;
function  HaveWin2K: Boolean;
function  HaveWinXP: Boolean;
function  TimeGetExactTime: int64;
procedure Delay(ms: DWORD; ProcessMessages: Boolean);
function  NonClientHeight: integer;
function  MenuHeight: integer;
function  BitsPerPixel: integer;
function  ClientToClient(Destination, Source: TControl; P: TPoint): TPoint;
{$IFDEF WIN32}
function  CreateFullDir(Dir: string): Boolean;
procedure DeleteDir(Dir: string);
{$ENDIF}
function  GetFileSize(Name: TFileName): Longint;
function  GetDiskStats(const Directory: string; var nFree, nSize: Int64): Boolean;
function  GetDiskFree(const Directory: string; nBytes: Longint): Boolean;
procedure ChangeColors(Bitmap: TBitmap; DrawInactive: Boolean;
                       ForeColor, InactiveColor, BackColor: TColor);
procedure GetBitmapSize(Bitmap: HBitmap; var W, H: integer);
function  GetTransparentColorEx(Bitmap: HBitmap; Point: TPoint): TColorRef;
function  GetTransparentColor(Bitmap: HBitmap): TColorRef;
procedure DrawTransparentBitmapEx(DC: HDC; Bitmap: HBitmap; X, Y: integer;
                                  Src: TRect; Transparent: TColorRef);
procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap;
                                X, Y: integer; Transparent: TColorRef);
procedure TileBlt(DC: HDC; Bitmap: HBitmap; const aRect:TRect; ROP: Longint);
procedure FillGradient(DC: HDC; BeginColor, EndColor: TColor;
                       nColors: integer; const aRect: TRect);
procedure FillSolid(DC: HDC; Color: TColor; const aRect: TRect);
function  WinExecAndWait(FileName: TFileName): Boolean;
function  WinExecAndWaitEx(FileName: TFileName; TimeOut: DWORD): Boolean;
procedure TimeDecode(Time: Longint; var Hour, Min, Sec, MSec: Word);
function  TimeToMask(Time: Longint): string;
function  MaskToTime(Mask: string): Longint;
function  CheckFloat(const S: string): string;
{$IFDEF WIN32}
function  TimeToString64Ex(Time: int64; MSec: Boolean): string;
function  TimeToString64(LowTime,HighTime: Cardinal; MSec: Boolean): string;
{$ENDIF}
function  TimeToStringEx(Time: MM_int64; MSec: Boolean): string;
function  TimeToString(Time: MM_int64): string;
function StrToFloatEx(S: string; Limiter: Char): Extended;
function  DBToLin(DB: Float): Float;
function  LinToDB(lin: Float): Float;
function  DBToVolume(DB: Float; Base: Longint): Longint;
function  VolumeToDB(Volume, Base: Longint): Float;
function  VolumeToStringShort(Volume, Base: Longint;  Precision: integer): string;
function  VolumeToString(Volume, Base: Longint;  Precision: integer): string;
function  PanningToString(Panning, Range: Longint): String;
procedure CalcVolume(Base,Volume,Panning: Longint; var Left, Right: Longint);
function  CombineVolume(Vol1,Vol2,Base: Longint): Longint;
function  FormatBigNumber(dw: Longint): String;
function  BytesToString(Bytes: Comp): string;
procedure DrawRubberband(Sender: TObject; aRect: TRect);
procedure DrawRubberLineEx(Sender: TObject; aRect: TRect; Pen: HPEN; ROP: DWORD);
procedure DrawRubberLine(Sender: TObject; aRect: TRect);
procedure TextOutAligned(Canvas: TCanvas; X, Y: integer; Text: String;
                         FontName: PChar; FontSize: integer; Align: Byte);
procedure WinYield(Wnd: THandle);
function  DesignMode: Boolean;
function  CheckPath(Path: string; Flag: Boolean): String;
function  CheckFileName(S: String): string;
function SearchParamStr(Switch: string): Boolean;
function int64shl32(V: int64; Shift: Byte): MMLarge_Integer;
{$IFDEF WIN32}
function  GetTempFile: string;
function  Min64(a, b: int64): int64;
function  Max64(a, b: int64): int64;
function  MinMax64(X, Min, Max: int64): int64;
function  InMinMax64(X,Min,Max: int64): Boolean;
function  Sign(Value: Longint): Longint;
{$ENDIF}
{$IFDEF WIN32}
{$IFNDEF DELPHI3}
type
    EWin32Error = class(Exception)
    public
        ErrorCode: DWORD;
    end;
function    SysErrorMessage(ErrorCode: Integer): string;
procedure   RaiseLastWin32Error;
function    Win32Check(RetVal: BOOL): BOOL;
{$ENDIF}
{$ENDIF}
{========================================================================}
var
   SwapSmall          : procedure (var a, b: SmallInt);
   SwapInt            : procedure (var a, b: integer);
   SwapLong           : procedure (var a, b: Longint);
   Min                : function  (a, b: Longint): Longint;
   Max                : function  (a, b: Longint): Longint;
   MinMax             : function  (X, Min, Max: Longint): Longint;
   Limit              : function  (X, Min, Max: Longint): Longint;
   InMinMax           : function  (X, Min, Max: Longint): Boolean;
   InRange            : function  (X, Min, Max: Longint): Boolean;
   incHuge            : procedure (Var Pointer; nBytes: Longint);
   GlobalFillMem      : procedure (var X; Cnt: Longint; Value: Byte);
   GlobalFillLong     : procedure (var X; Cnt: Longint; Value: Longint);
   GlobalMoveMem      : procedure (const Source; var Dest; Cnt: Longint);
   GlobalCmpMem       : function  (const p1, p2; Cnt: Longint): Boolean;
   {$IFDEF TRIAL}
   IDERunning         : function: Boolean;
   CheckTime          : function: Boolean;
   CheckParam1        : function  (dw1: DWORD; b1: BOOL; lp1: PChar): THandle; stdcall;
   CheckParam2        : function  (lp1, lp2: PChar; dw1: DWORD; lp3, lp4, lp5: PDWORD;
                                   lp6: PChar; dw2: DWORD): Boolean; stdcall;
   {$ENDIF}
function  GlobalAllocMem(Size: Longint): Pointer;
procedure GlobalReAllocMem(var p: Pointer; Size: Longint);
procedure GlobalFreeMem(var p: Pointer);
function  GlobalMemSize(const p: Pointer): Longint;
procedure RegisterPackage(const Pack: string); {$IFDEF BUILD_ACTIVEX} stdcall; export; {$ENDIF}
procedure RegisterFailed(Code: Longint; Control: TComponent; Text: string);
procedure RegisterComponent(Code: Longint; Control: TComponent; Text: string);
function  ComponentRegistered(Code: Longint; Control: TComponent; Text: string): Longint;
function  PackageRegistered(Pack: string): integer;
function FindIDERunning: Boolean;
implementation
uses
    MMSystem,
    MMString,
    MMSearch,
    MMMulDiv,
    MMMath,
    MMInt64
    {$IFDEF _MMDEBUG_}
    ,MMDebug
    {$ENDIF}
    ;
{$IFNDEF WIN32}
{=========================================================================}
procedure MoveWindowOrg(DC: HDC; DX, DY: Integer);
var
  P: TPoint;
begin
   GetWindowOrgEx(DC, @P);
   SetWindowOrgEx(DC, P.X - DX, P.Y - DY, nil);
end;
{$ELSE}
var
   TransSection: TRTLCriticalSection;
   _GetDiskFreeSpaceEx: function (Directory: PChar; var FreeAvailable,
                                  TotalSpace: Int64;
                                  TotalFree: PInt64): Bool stdcall = nil;
{=========================================================================}
function MMSetThreadPriority(hThread: THandle; nPriority: integer): Boolean;
begin
(*
   if (GetPriorityClass(GetCurrentProcess) = REALTIME_PRIORITY_CLASS) then
   begin
      case nPriority of
         //THREAD_PRIORITY_IDLE          : nPriority := ;
         THREAD_PRIORITY_LOWEST        : nPriority := THREAD_PRIORITY_IDLE;
         THREAD_PRIORITY_BELOW_NORMAL  : nPriority := THREAD_PRIORITY_LOWEST;
         THREAD_PRIORITY_NORMAL        : nPriority := THREAD_PRIORITY_BELOW_NORMAL;
         THREAD_PRIORITY_ABOVE_NORMAL  : nPriority := THREAD_PRIORITY_NORMAL;
         //THREAD_PRIORITY_HIGHEST       = THREAD_BASE_PRIORITY_MAX;
         //THREAD_PRIORITY_TIME_CRITICAL = THREAD_BASE_PRIORITY_LOWRT;
      end;
   end;
*)
   Result := SetThreadPriority(hThread,nPriority);
end;
{=========================================================================}
function MMSetPriorityClass(hProcess: THandle; fdwPriority: DWORD): Boolean;
begin
   Result := SetPriorityClass(hProcess,fdwPriority);
end;
{=========================================================================}
procedure SaveInRegistry(_RootKey:HKEY;_Localkey,_Field:String;Value:Variant);
begin
   try
      with TRegistry.Create do
      try
         { default is  RootKey=HKEY_CURRENT_USER  }
         case _RootKey of
              HKEY_CLASSES_ROOT,
              HKEY_CURRENT_USER,
              HKEY_LOCAL_MACHINE,
              HKEY_USERS,
              HKEY_PERFORMANCE_DATA,
              HKEY_CURRENT_CONFIG,
              HKEY_DYN_DATA : RootKey := _RootKey;
         end;
         OpenKey(_Localkey,True);
         case VarType(Value) of
             varByte,
             varNull,
             varInteger,
             varSmallint: WriteInteger (_Field,Value);
             varSingle,
             varDouble  : WriteFloat   (_Field,Value);
             varCurrency: WriteCurrency(_Field,Value);
             varDate    : WriteDateTime(_Field,Value);
             varBoolean : WriteBool    (_Field,Value);
             varString,
             varOleStr  : WriteString  (_Field,Value);
         end;
         CloseKey;
      finally
         Free;
      end;
   except
   end;
end;
{=========================================================================}
procedure SaveInRegistryBinary(_RootKey:HKEY;_Localkey,_Field:string;var Buffer; BufSize: integer);
begin
   try
      if (BufSize > 0) then
      with TRegistry.Create do
      try
         { default is  RootKey=HKEY_CURRENT_USER  }
         case _RootKey of
             HKEY_CLASSES_ROOT,
             HKEY_CURRENT_USER,
             HKEY_LOCAL_MACHINE,
             HKEY_USERS,
             HKEY_PERFORMANCE_DATA,
             HKEY_CURRENT_CONFIG,
             HKEY_DYN_DATA : RootKey := _RootKey;
         end;
         OpenKey(_Localkey,True);
         WriteBinaryData(_Field,Buffer,BufSize);
         CloseKey;
      finally
          Free;
      end;
   except
   end;
end;
{=========================================================================}
function GetFromRegistry(_RootKey:HKEY;_Localkey,_Field:String;Value:Variant): Variant;
begin
   Result := Value;
   try
      with TRegistry.Create do
      try
         { default is  RootKey=HKEY_CURRENT_USER  }
         case _RootKey of
              HKEY_CLASSES_ROOT,
              HKEY_CURRENT_USER,
              HKEY_LOCAL_MACHINE,
              HKEY_USERS,
              HKEY_PERFORMANCE_DATA,
              HKEY_CURRENT_CONFIG,
              HKEY_DYN_DATA : RootKey := _RootKey;
         end;
         if OpenKey(_Localkey, False) then
         begin
            if ValueExists(_Field) then
            case VarType(Value) of
                varByte,
                varNull,
                varInteger,
                varSmallint: Result := ReadInteger(_Field);
                varSingle,
                varDouble  : Result := ReadFloat   (_Field);
                varCurrency: Result := ReadCurrency(_Field);
                varDate    : Result := ReadDateTime(_Field);
                varBoolean : Result := ReadBool    (_Field);
                varString,
                varOleStr  : Result := ReadString  (_Field);
            end;
            CloseKey;
         end;
      finally
         Free;
      end;
   except
   end;
end;
{=========================================================================}
function GetFromRegistryBinary(_RootKey:HKEY;_Localkey,_Field:string;var Buffer; BufSize: integer): integer;
begin
   Result := 0;
   try
      with TRegistry.Create do
      try
         { default is  RootKey=HKEY_CURRENT_USER  }
         case _RootKey of
             HKEY_CLASSES_ROOT,
             HKEY_CURRENT_USER,
             HKEY_LOCAL_MACHINE,
             HKEY_USERS,
             HKEY_PERFORMANCE_DATA,
             HKEY_CURRENT_CONFIG,
             HKEY_DYN_DATA : RootKey := _RootKey;
         end;
         if OpenKey(_Localkey, False) then
         begin
            if ValueExists(_Field) then
            begin
               if (BufSize = 0) then
                   Result := GetDataSize(_Field)
               else
                   Result := ReadBinaryData(_Field,Buffer,BufSize);
            end;
            CloseKey;
         end;
      finally
         Free;
      end;
   except
   end;
end;
{=========================================================================}
function GetCPUUsage: integer;
var
   TempKey: HKEY;
   DataType,BufSize,Dummy: integer;
begin
   Result := 0;
   if _WIN9x_ or _WINNT_NEW_ then
   begin
      TempKey := 0;
      { start measuring }
      if RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStatsStartStat', 0,
                      KEY_ALL_ACCESS, TempKey) <> ERROR_SUCCESS then exit;
      DataType := REG_NONE;
      BufSize := sizeOf(integer);
      if RegQueryValueEx(TempKey, 'KERNELCPUUsage', nil, @DataType,
                         @Dummy, @BufSize) <> ERROR_SUCCESS then exit;
      RegCloseKey(TempKey);
      { get the value }
      if RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStatsStatData', 0,
                      KEY_ALL_ACCESS, TempKey) <> ERROR_SUCCESS then exit;
      RegCloseKey(TempKey);
      DataType := REG_NONE;
      BufSize := sizeOf(integer);
      if RegQueryValueEx(TempKey, 'KERNELCPUUsage', nil, @DataType,
                         @Result, @BufSize) <> ERROR_SUCCESS then exit;
      RegCloseKey(TempKey);
      { stop measuring }
      if RegOpenKeyEx(HKEY_DYN_DATA, 'PerfStatsStopStat', 0,
                      KEY_ALL_ACCESS, TempKey) <> ERROR_SUCCESS then exit;
      DataType := REG_NONE;
      BufSize := sizeOf(integer);
      if RegQueryValueEx(TempKey, 'KERNELCPUUsage', nil, @DataType,
                         @Dummy, @BufSize) <> ERROR_SUCCESS then exit;
      RegCloseKey(TempKey);
   end;
end;
{=========================================================================}
function GetShortFileName(Name: TFileName): String;
var
   SearchRec: TSearchRec;
begin
   Result := '';
   Name := ExpandUNCFileName(Name);
   if (Name <> '') and FileExists(Name) then
   begin
      if (FindFirst(Name,faAnyFile,SearchRec) = 0) and
          Equal(SearchRec.Name, ExtractFileName(Name)) then
      try
         if SearchRec.FindData.cAlternateFileName[0] <> #0 then
            Result := StrPas(SearchRec.FindData.cAlternateFileName)
         else
            Result := StrPas(SearchRec.FindData.cFileName);
      finally
         FindClose(SearchRec);
      end;
   end;
end;
{=========================================================================}
{ Returns:                                                                }
{  0 = 8086/88,80286,80386,80486                                          }
{  1 = Pentium(R) Processor                                               }
{  2 = PentiumPro(R) Processor                                            }
{  3 or higher = Processor beyond the PentiumPro(R) Processor            }
{                                                                         }
{=========================================================================}
function GetCPUType: integer;
var
   stepping: Byte;
   model: Byte;
begin
   Result := 0;
{$IFDEF WIN32}
   asm
      pushad
      pushfd
      { look if cpuid is supported }
      pushfd			// Get original EFLAGS
      pop    eax
      mov    ecx, eax
      xor    eax, 200000h	// Flip ID bit in EFLAGS
      push   eax		// Save new EFLAGS value on
      				//   stack
      popfd			// Replace current EFLAGS value
      pushfd			// Get new EFLAGS
      pop     eax		// Store new EFLAGS in EAX
      xor     eax, ecx		// Can not toggle ID bit,
      jz      @@exit		// Processor=80486
      mov     eax, 1
      db      $0F
      db      $a2		// Get family/model/stepping/
        			//   features
      mov     stepping, al
      and     stepping, $F
      and     al, $F0
      shr     al, 4
      mov     model, al
      and     eax, $F00
      shr     eax, 8		// Isolate family
      and     eax, $F
      sub     eax, 4
      mov     Result, eax	// Set _cpu_type with family
   @@exit:
      popfd
      popad
   end;
{$ENDIF}
end;
{=========================================================================}
function Min64(a, b: int64): int64;
begin
   if a > b then Result := b
   else Result := a;
end;
{=========================================================================}
function Max64(a, b: int64): int64;
begin
   if a > b then Result := a
   else Result := b;
end;
{=========================================================================}
function MinMax64(X, Min, Max: int64): int64;
begin
   if (X < Min) then X := Min
   else if (X > Max) then X := Max;
   Result := X;
end;
{=========================================================================}
function InMinMax64(X,Min,Max: int64): Boolean;
begin
   { if Min > Max then Result is never true }
   if (X < Min) then Result := False
   else if (X > Max) then Result := False
   else Result := True;
end;
{=========================================================================}
function Sign(Value: Longint): Longint;
begin
   if (Value > 0) then
       Result := 1
   else if (Value < 0) then
       Result := -1
   else
       Result := Value;
end;
{=========================================================================}
{ Current flag assignment is as follows:                                  }
{                                                                         }
{		bit23=1     CPU has MMX extension                         }
{		bit15=1     CMOV instruction supported                    }
{		bit9 =1     CPU contains a local APIC (iPentium-3V)       }
{		bit8 =1     CMPXCHG8B instruction supported               }
{		bit7 =1     machine check exception supported             }
{		bit6 =0     reserved (36bit-addressing & 2MB-paging)      }
{		bit5 =1     iPentium-style MSRs supported                 }
{		bit4 =1     time stamp counter TSC supported              }
{		bit3 =1     page size extensions supported                }
{		bit2 =1     I/O breakpoints supported                     }
{		bit1 =1     enhanced virtual 8086 mode supported          }
{		bit0 =1     CPU contains a floating-point unit (FPU)      }
{=========================================================================}
function GetCPUFeatures: Longint;
begin
   Result := 0;
{$IFDEF WIN32}
   asm
      pushad
      pushfd
      { look if cpuid is supported }
      pushfd			// Get original EFLAGS
      pop    eax
      mov    ecx, eax
      xor    eax, 200000h	// Flip ID bit in EFLAGS
      push   eax		// Save new EFLAGS value on
      				//   stack
      popfd			// Replace current EFLAGS value
      pushfd			// Get new EFLAGS
      pop     eax		// Store new EFLAGS in EAX
      xor     eax, ecx		// Can not toggle ID bit,
      jz      @@exit		// Processor=80486
      mov     eax, 1
      db      $0F
      db      $a2		// Get family/model/stepping/
        			//   features
      mov     Result, edx
   @@exit:
      popfd
      popad
   end;
{$ENDIF}
end;
{=========================================================================}
{ Returns:                                                                }
{  0 = Pentium(R) Processor                                               }
{  1 = PentiumPro(R) Processor                                            }
{  2 = MMX Extension                                                      }
{=========================================================================}
function GetCPUMode: integer;
begin
   if _USECPUEXT_ then
   begin
      if _MMX_ then
         Result := 2
      else if _CPU_ > PENTIUM then
         Result := 1
      else
         Result := 0;
   end
   else Result := 0;
end;
{=========================================================================}
function GetCPUCycles: int64;
asm
{$IFDEF WIN32}
      db      00fh              //RDTSC
      db      031h
      {$IFNDEF DELPHI4}
      mov     TLargeInteger(Result).HighPart,edx
      mov     TLargeInteger(Result).LowPart,eax
      {$ENDIF}
{$ENDIF}
end;
var
   TimeCount: Longint;
   OldTime,TimeMin,TimeMax,TimeAvg: int64;
{=========================================================================}
procedure InitTimeMeasure;
begin
   TimeCount:= 0;
   TimeMin  := MAXLONGINT;
   TimeMax  := 0;
   TimeAvg  := 0;
end;
{=========================================================================}
procedure StartTimeMeasure;
begin
   inc(TimeCount);
   OldTime := TimeGetExactTime;
end;
{=========================================================================}
function StopTimeMeasure(Scale: integer): string;
var
   CurTime: int64;
begin
   CurTime := TimeGetExactTime-OldTime;
   if (CurTime < TimeMin) then TimeMin := CurTime;
   if (CurTime > TimeMax) then TimeMax := CurTime;
   TimeAvg := TimeAvg+CurTime;
   if Scale < 1 then Scale := 1;
   Result := Format('Time:  Cur: %f  Min: %f  Max: %f  Avg: %f',[CurTime,
                                                                 TimeMin/Scale,
                                                                 TimeMax/Scale,
                                                                 (TimeAvg/TimeCount)/Scale]);
end;
var
   CycleCount: Longint;
   OldCycles,CyclesMin,CyclesMax,CyclesAvg: int64;
{=========================================================================}
procedure InitCyclesMeasure;
begin
   CycleCount := 0;
   CyclesMin  := MAXLONGINT;
   CyclesMax  := 0;
   CyclesAvg  := 0;
end;
{=========================================================================}
procedure StartCyclesMeasure;
begin
   inc(CycleCount);
   OldCycles := GetCPUCycles;
end;
{=========================================================================}
function StopCyclesMeasure(Scale: integer): string;
var
   CurCycles: int64;
begin
   CurCycles := GetCPUCycles-OldCycles;
   if (CurCycles < CyclesMin) then CurCycles := CyclesMin;
   if (CurCycles > CyclesMax) then CurCycles := CyclesMax;
   CyclesAvg := CyclesAvg+CurCycles;
   if Scale < 1 then Scale := 1;
   Result := Format('CPU-Cycles:  Min: %f Max: %f Avg: %f',[CyclesMin/Scale,
                                                            CyclesMax/Scale,
                                                            (CyclesAvg/CycleCount)/Scale]);
end;
{$ENDIF}
const
     Freq: Longint = 0;
{=========================================================================}
function TimeGetExactTime: int64;
{$IFDEF WIN32}
var
   {$IFDEF DELPHI4}
   CurTime: int64;
   {$ELSE}
   CurTime: MMLARGE_INTEGER;
   {$ENDIF}
{$ENDIF}
begin
   { returns system time in micro second }
{$IFDEF WIN32}
   if (Freq = 0) then
   begin
      QueryPerformanceFrequency(CurTime);           { determine timer frequency }
      {$IFDEF DELPHI4}
      if (Curtime shr 32 > 0) then
          Freq := 1                                 { timer is too fast }
      else
          Freq := CurTime and $FFFFFFFF;            { ticks per second }
      {$ELSE}
      if (Curtime.HighPart > 0) then
          Freq := 1                                 { timer is too fast }
      else
          Freq := CurTime.LowPart;                  { ticks per second }
      {$ENDIF}
   end;
   if (Freq > 1) then
   begin
      QueryPerformanceCounter(CurTime);
      {$IFDEF DELPHI4}
      Result := (1000000 * CurTime) div Freq;
      {$ELSE}
      Result := 1000000;
      Result := (Result * CurTime.QuadPart)/Freq;
      {$ENDIF}
   end
   else
{$ENDIF}
   begin
      { on Win16 we must return the time in a 1000 micro second raster }
      Result := 1000;
      Result := Result * TimeGetTime;
   end;
end;
{=========================================================================}
function HaveWin95: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) and
             (OS.dwMajorVersion = 4) and (OS.dwMinorVersion = 0);
{$ELSE}
begin
   Result:=(GetVersion and $FF = 3)and((GetVersion shr 8)and $FF=95);
{$ENDIF}
end;
{=========================================================================}
function HaveWin98: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) and
             (OS.dwMajorVersion = 4) and (OS.dwMinorVersion = 10);
{$ELSE}
begin
   Result:=(GetVersion and $FF = 3)and((GetVersion shr 8)and $FF=95);
{$ENDIF}
end;
{=========================================================================}
function HaveWinME: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_WINDOWS) and
             (OS.dwMajorVersion = 4) and (OS.dwMinorVersion = 90);
{$ELSE}
begin
   Result:=(GetVersion and $FF = 3)and((GetVersion shr 8)and $FF=95);
{$ENDIF}
end;
{=========================================================================}
function HaveWinNT: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_NT) and
             (OS.dwMajorVersion = 3);
{$ELSE}
begin
   Result := (GetWinFlags and $4000) <> 0;
{$ENDIF}
end;
{=========================================================================}
function HaveWinNT4: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_NT) and
             (OS.dwMajorVersion >= 4);
{$ELSE}
begin
   Result := (GetWinFlags and $4000) <> 0;
{$ENDIF}
end;
{=========================================================================}
function HaveWin2K: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_NT) and
             (OS.dwMajorVersion >= 5);
{$ELSE}
begin
   Result := (GetWinFlags and $4000) <> 0;
{$ENDIF}
end;
{=========================================================================}
function HaveWinXP: Boolean;
{$IFDEF WIN32}
var
   OS: TOSVERSIONINFO;
begin
   OS.dwOSVersionInfoSize := sizeOf(OS);
   GetVersionEx(OS);
   Result := (OS.dwPlatformID = VER_PLATFORM_WIN32_NT) and
             (OS.dwMajorVersion >= 5) and (OS.dwMinorVersion = 1);
{$ELSE}
begin
   Result := (GetWinFlags and $4000) <> 0;
{$ENDIF}
end;
{=========================================================================}
procedure Delay(ms: DWORD; ProcessMessages: Boolean);
Var
   Time: DWORD;
begin
  if ms > 0 then
  begin
{$IFDEF WIN32}
    if ProcessMessages then
    begin
      Time := GetTickCount;
      repeat
        case MsgWaitForMultipleObjects(0, nil^, True, Time - GetTickCount + ms, QS_ALLEVENTS) of
          WAIT_OBJECT_0:
          begin
            Application.ProcessMessages;
            if GetTickCount-Time >= ms then break;
          end;
          WAIT_TIMEOUT:
            break;
        end
      until csDestroying in Application.ComponentState
    end
    else Sleep(ms);
{$ELSE}
    Time := GetTickCount;
    repeat
      if ProcessMessages then Application.ProcessMessages;
    until GetTickCount-Time >= ms;
{$ENDIF}
  end;
end;
{=========================================================================}
function ClientToClient(Destination, Source: TControl; P: TPoint): TPoint;
begin
   Result := Destination.ScreenToClient(Source.ClientToScreen(P));
end;
{=========================================================================}
function NonClientHeight: integer;
begin
   { returns the full CaptionBar height }
   Result := GetSystemMetrics(SM_CYCAPTION)+2*GetSystemMetrics(SM_CYFRAME);
end;
{=========================================================================}
function MenuHeight: integer;
begin
   { returns the full Menu height }
   Result := GetSystemMetrics(SM_CYMENU	);
end;
{=========================================================================}
function BitsPerPixel: integer;
var
   DC: HDC;
begin
   { returns "Bits Per Pixel" for the actual display
     1     = 16 Color
     8     = 256 Color,
     15/16 = HiColor
     24/32 = TrueColor }
   DC := CreateDC('DISPLAY',nil,nil,nil);
   Result := GetDeviceCaps(DC,BITSPIXEL);
   DeleteDC(DC);
end;
{=========================================================================}
function CheckPath(Path: string; Flag: Boolean): String;
{Funktion pr黤t, ob letztes Zeichen in Pfadangabe ein '' ist
 Flag:
        TRUE - '' Zeichen erw黱scht
        FALSE - '' Zeichen unerw黱scht}
begin
     if (Path <> '') then
     begin
        if (Flag = True) then
        begin
           if Path[Length(Path)] <> '' then
              Path := Path + ''
        end
        else
        begin
           if Path[Length(Path)] = '' then
              Path := Copy(Path,1,Length(Path)-1);
        end;
     end;
     Result := Path;
end;
{=========================================================================}
function CheckFileName(S: String): string;
var
   i: integer;
   FName: string;
begin
   for i := 1 to Length(S) do
   begin
      if (S[i] in ['/','*','?','"','<','>','|',',']) or ((S[i] = ':') and (S[i+1] <> '')) then
          S[i] := '_';
   end;
   FName := ChangeFileExt(ExtractFileName(S),'');
   for i := 1 to Length(FName) do
   begin
      if (FName[i] in ['','.']) then
          FName[i] := '_';
   end;
   Result := CheckPath(ExtractFilePath(S),True)+FName+ExtractFileExt(S);
end;
{==============================================================================}
function int64shl32(V: int64; Shift: Byte): MMLarge_Integer;
var
   R: MMLarge_Integer;
begin
   asm
     {$IFDEF WIN32}
      mov   cl, Shift
      mov   eax, dword ptr V[0]
      mov   edx, dword ptr V[4]
      shld  edx, eax, cl
      shl   eax, cl
      mov   dword ptr R.HighPart, edx
      mov   dword ptr R.LowPart, eax
      {$ELSE}
      mov   cl, Shift
      db    66h
      mov   ax, word ptr V[0]
      db    66h
      mov   dx, word ptr V[4]
      db    66h      { shld  edx, eax, cl }
      db    0Fh
      db    0A5h
      db    0C2h
      db    66h
      shl   ax, cl
      db    66h
      mov   word ptr R.HighPart, dx
      db    66h
      mov   word ptr R.LowPart, ax
      {$ENDIF}
   end;
   Result := R;
end;
{$IFDEF WIN32}
{=========================================================================}
function GetTempFile: string;
var
   aBuf: array[0..MAX_PATH] of Char;
begin
   GetTempPath(sizeOf(aBuf)-1,aBuf);
   GetTempFileName(aBuf,'w'#0,Random(256)+1,aBuf);
   Result := StrPas(aBuf);
end;
{=========================================================================}
function CreateFullDir(Dir: string): Boolean;
var
   Drive,Path,S: string;
   idx: integer;
   function ExtractPathTotken(idx: integer; S: string): string;
   var
      x,p: integer;
   begin
      Result := '';
      x := -1;
      while (x < idx) do
      begin
         p := Pos('',S);
         if (p <= 0) then
         begin
            Result := '';
            exit;
         end;
         Result := Result+Copy(S,1,p);
         Delete(S,1,p);
         inc(x);
      end;
   end;
begin
   Result := False;
   Dir := CheckPath(Dir,True);
   Drive := CheckPath(ExtractFileDrive(Dir),True);
   Path  := CheckPath(Copy(ExtractFilePath(Dir),Length(Drive)+1,Length(Dir)),True);
   if (Drive = '') or (Path = '') then exit;
   idx := 0;
   repeat
      S := ExtractPathTotken(idx,Path);
      if (S <> '') then
      begin
         if not DirectoryExists(Drive+S) then
         begin
            if not CreateDir(Drive+S) then
            begin
               Result := False;
               exit;
            end;
         end;
         inc(idx);
      end;
   until (S = '');
   Result := True;
end;
{=========================================================================}
procedure DeleteDir(Dir: string);
var
   Result: integer;
   SearchRec: TSearchRec;
begin
   Dir := CheckPath(Dir,True);
   Result := FindFirst(Dir+'*.*',faAnyFile,SearchRec);
   try
      while (Result = 0) do
      begin
         if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
             DeleteFile(Dir+SearchRec.Name);
         Result := FindNext(SearchRec);
      end;
   finally
      FindClose(SearchRec);
   end;
   RemoveDir(Dir);
end;
{$ENDIF}
{=========================================================================}
function GetFileSize(Name: TFileName): Longint;
var
   SearchRec: TSearchRec;
begin
   try
      if FindFirst(ExpandFileName(Name), faAnyFile, SearchRec) = 0 then
         Result := SearchRec.Size
      else
         Result := -1;
   finally
      FindClose(SearchRec);
   end;
end;
{$IFDEF WIN32}
{ This function is used if the OS doesn't support GetDiskFreeSpaceEx }
{=========================================================================}
function BackfillGetDiskFreeSpaceEx(Directory: PChar; var FreeAvailable,
                                    TotalSpace: Int64;
                                    TotalFree: PInt64): Bool; stdcall;
var
  SectorsPerCluster, BytesPerSector, FreeClusters, TotalClusters: DWORD;
  Temp: Int64;
  Dir : PChar;
begin
  if Directory <> nil then
     Dir := PChar(ExtractFileDrive(Directory)+'')
  else
     Dir := nil;
  Result := GetDiskFreeSpace(Dir, SectorsPerCluster, BytesPerSector,
                             FreeClusters, TotalClusters);
  Temp := SectorsPerCluster;
  Temp := Temp * BytesPerSector;
  FreeAvailable := Temp * FreeClusters;
  TotalSpace    := Temp * TotalClusters;
end;
{$ENDIF}
{=========================================================================}
function GetDiskStats(const Directory: string; var nFree, nSize: Int64): Boolean;
{$IFDEF WIN32}
begin
   Result := _GetDiskFreeSpaceEx(PChar(ExtractFileDir(Directory)),nFree, nSize, nil);
   if not Result then
   begin { avoid errors from unchecked divisions }
      nFree := 0;
      nSize := 1;
   end;
{$ELSE}
var
   iDrive: Byte;
begin
   iDrive := Byte(UpCase(Directory[0]))-64;
   nSize := DiskSize(iDrive);
   nFree := DiskFree(iDrive);
   Result := True;
{$ENDIF}
end;
{=========================================================================}
function GetDiskFree(const Directory: string; nBytes: Longint): Boolean;
var
   nFree,nSize,n: Int64;
begin
   Result := False;
   if GetDiskStats(Directory,nFree,nSize) then
   begin
      n := nBytes;
      Result := nFree >= n;
   end;
end;
const
     RC_Active     = clWhite; { the resource color for active sements    }
     RC_Inactive   = clSilver;{ the resource color for inactive segments }
     RC_Background = clBlack; { the resource color for the background    }
{=========================================================================}
{ Change the black/white SrcBitmap to a colored DestBitmap                }
{=========================================================================}
procedure ChangeColors(Bitmap: TBitmap; DrawInactive: Boolean;
                       ForeColor, InactiveColor, BackColor: TColor);
Var
   aRect: TRect;
   MaskF, MaskB, MaskI: TBitmap;
   function CreateMask(Bmp: TBitmap; Color: TColor): TBitmap;
   begin
      Result := TBitmap.Create;
      with Result do
      begin
         Monochrome  := True;
         Width       := Bmp.Width;
         Height      := Bmp.Height;
         SetBkColor(Bmp.Canvas.Handle,ColorToRGB(Color));
         Canvas.Draw(0,0,Bmp);
      end;
   end;
   procedure PutMask(Bmp: TBitmap; aMask: TBitmap; Color: TColor; Mode: TCopyMode);
   begin
      with Bmp do
      begin
         Canvas.CopyMode := Mode;
         SetTextColor(Canvas.Handle,0);
         SetBkColor(Canvas.Handle,ColorToRGB(Color));
         Canvas.StretchDraw(Bounds(0,0,Width,Height),aMask);
      end;
   end;
begin
    aRect := Rect(0,0,Bitmap.Width,Bitmap.Height);
    MaskF := CreateMask(Bitmap,RC_ACTIVE);
    try
        MaskB := CreateMask(Bitmap,RC_Background);
        try
            MaskI := CreateMask(Bitmap,RC_INACTIVE);
            try
                PutMask(Bitmap,MaskF,ForeColor,cmSrcCopy);
                PutMask(Bitmap,MaskB,BackColor,cmSrcInvert);
                if DrawInactive then
                    PutMask(Bitmap,MaskI,InactiveColor,cmSrcInvert)
                else
                    PutMask(Bitmap,MaskI,BackColor,cmSrcInvert);
            finally
                MaskI.Free;
            end;
        finally
            MaskB.Free;
        end;
    finally
        MaskF.Free;
    end;
end;
{=========================================================================}
procedure GetBitmapSize(Bitmap: HBitmap; var W, H: integer);
var
{$IFDEF WIN32}
   bm: Windows.TBitmap;
{$ELSE}
   bm: WinTypes.TBitmap;
{$ENDIF}
begin
   GetObject(Bitmap, SizeOf(bm), @bm);
   W := bm.bmWidth;
   H := bm.bmHeight;
end;
{=========================================================================}
function GetTransparentColorEx(Bitmap: HBitmap; Point: TPoint): TColorRef;
var
   MemDC: HDC;
   OldBitmap: HBITMAP;
   W,H: integer;
begin
   MemDC := CreateCompatibleDC(0);
   OldBitmap := SelectObject(MemDC, Bitmap);
   GetBitmapSize(Bitmap,W,H);
   Point.X := MinMax(Point.X,0,W-1);
   Point.Y := MinMax(Point.Y,0,H-1);
   Result := GetPixel(MemDC,Point.X,Point.Y);
   SelectObject(MemDC, OldBitmap);
   DeleteDC(MemDC);
end;
{=========================================================================}
function GetTransparentColor(Bitmap: HBitmap): TColorRef;
begin
   Result := GetTransparentColorEx(Bitmap,Point(0,MaxInt-1));
end;
{=========================================================================}
procedure DrawTransparentBitmapEx(DC: HDC; Bitmap: HBitmap; X, Y: integer;
                                  Src: TRect; Transparent: TColorRef);
type
    _TPoint = record
        X: integer;
        Y: integer;
    end;
var
   cColor          : TColorRef;
   bmAndBack,
   bmAndObject,
   bmAndMem,
   bmSave,
   bmBackOld,
   bmObjectOld,
   bmMemOld,
   bmSaveOld       : HBitmap;
   hdcMem,
   hdcBack,
   hdcObject,
   hdcTemp,
   hdcSave         : HDC;
   bmWidth,bmHeight: integer;
begin
   {$IFDEF WIN32}
   EnterCriticalSection(TransSection);
   try
   {$ENDIF}
      hdcTemp := CreateCompatibleDC(DC);
      SelectObject(hdcTemp, Bitmap); { select the bitmap }
      bmWidth  := Src.Right-Src.Left;
      bmHeight := Src.Bottom-Src.Top;
      { create some DCs to hold temporary data }
      hdcBack   := CreateCompatibleDC(DC);
      hdcObject := CreateCompatibleDC(DC);
      hdcMem    := CreateCompatibleDC(DC);
      hdcSave   := CreateCompatibleDC(DC);
      { create a bitmap for each DC }
      { monochrome DC }
      bmAndBack   := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
      bmAndObject := CreateBitmap(bmWidth, bmHeight, 1, 1, nil);
      bmAndMem    := CreateCompatibleBitmap(DC, bmWidth, bmHeight);
      bmSave      := CreateCompatibleBitmap(DC, bmWidth, bmHeight);
      { each DC must select a bitmap object to store pixel data }
      bmBackOld   := SelectObject(hdcBack, bmAndBack);
      bmObjectOld := SelectObject(hdcObject, bmAndObject);
      bmMemOld    := SelectObject(hdcMem, bmAndMem);
      bmSaveOld   := SelectObject(hdcSave, bmSave);
      { set proper mapping mode }
      SetMapMode(hdcTemp, GetMapMode(DC));
      { save the bitmap sent here, because it will be overwritten }
      BitBlt(hdcSave, 0, 0, bmWidth, bmHeight, hdcTemp, Src.Left, Src.Top, SRCCOPY);
      { set the background color of the source DC to the color.
        contained in the parts of the bitmap that should be transparent }
      cColor := SetBkColor(hdcTemp, ColorToRGB(Transparent));
      { create the object mask for the bitmap by performing a BitBlt()
        from the source bitmap to a monochrome bitmap }
      BitBlt(hdcObject, 0, 0, bmWidth, bmHeight, hdcTemp, Src.Left, Src.Top, SRCCOPY);
      { set the background color of the source DC back to the original color }
      SetBkColor(hdcTemp, cColor);
      { create the inverse of the object mask }
      BitBlt(hdcBack, 0, 0, bmWidth, bmHeight, hdcObject, 0, 0, NOTSRCCOPY);
      { copy the background of the main DC to the destination }
      BitBlt(hdcMem, 0, 0, bmWidth, bmHeight, DC, X, Y, SRCCOPY);
      { mask out the places where the bitmap will be placed }
      BitBlt(hdcMem, 0, 0, bmWidth, bmHeight, hdcObject, 0, 0, SRCAND);
      { mask out the transparent colored pixels on the bitmap }
      BitBlt(hdcTemp, Src.Left, Src.Top, bmWidth, bmHeight, hdcBack, 0, 0, SRCAND);
      { XOR the bitmap with the background on the destination DC }
      BitBlt (hdcMem, 0, 0, bmWidth, bmHeight, hdcTemp, Src.Left, Src.Top, SRCPAINT);
      { copy the destination to the screen }
      BitBlt(DC, X, Y, bmWidth, bmHeight, hdcMem, 0, 0, SRCCOPY);
      { place the original bitmap back into the bitmap sent here }
      BitBlt(hdcTemp, Src.Left, Src.Top, bmWidth, bmHeight, hdcSave, 0, 0, SRCCOPY);
      { delete the memory bitmaps }
      DeleteObject(SelectObject(hdcBack, bmBackOld));
      DeleteObject(SelectObject(hdcObject, bmObjectOld));
      DeleteObject(SelectObject(hdcMem, bmMemOld));
      DeleteObject(SelectObject(hdcSave, bmSaveOld));
      { delete the memory DCs }
      DeleteDC(hdcMem);
      DeleteDC(hdcBack);
      DeleteDC(hdcObject);
      DeleteDC(hdcSave);
      DeleteDC(hdcTemp);
   {$IFDEF WIN32}
   finally
      LeaveCriticalSection(TransSection);
   end;
   {$ENDIF}
end;
{=========================================================================}
procedure DrawTransparentBitmap(DC: HDC; Bitmap: HBitmap; X, Y: integer;
                                Transparent: TColorRef);
var
   Src: TRect;
begin
   Src.TopLeft := Point(0,0);
   { convert bitmap dimensions from device to logical points }
   GetBitmapSize(Bitmap, Src.Right, Src.Bottom);
   DrawTransparentBitmapEx(DC, Bitmap, X, Y,
                           Src, Transparent);
end;
{=========================================================================}
procedure TileBlt(DC: HDC; Bitmap: HBitmap; const aRect: TRect; ROP: Longint);
{ This procedure tiles the given Bitmap aBitmap on DC. }
{ aRect specifies the dimensions                       }
var
   aWidth, aHeight,W,H: integer;
   TempDC: HDC;
   oldBitmap: HBitmap;
   i,j : integer;
begin
   {$IFDEF WIN32}
   EnterCriticalSection(TransSection);
   try
   {$ENDIF}
      OldBitmap := 0;
      TempDC := CreateCompatibleDC(DC);
      try
         OldBitmap := SelectObject(TempDC, Bitmap); { select the bitmap }
         GetBitmapSize(Bitmap,aWidth,aHeight);
         i := 0;
         H := aRect.Bottom-aRect.Top;
         while H > 0 do
         begin
            j := 0;
            W := aRect.Right-aRect.Left;
            while W > 0 do
            begin
               BitBlt(DC, aRect.Left+j*aWidth, aRect.Top+i*aHeight,
                      Min(aWidth,W), Min(aHeight,H),
                      TempDC,0,0,ROP);
               dec(W,aWidth);
               inc(j);
            end;
            dec(H,aHeight);
            inc(i);
         end;
      finally
         SelectObject(TempDC, OldBitmap);
         DeleteDC(TempDC);
      end;
   {$IFDEF WIN32}
   finally
      LeaveCriticalSection(TransSection);
   end;
   {$ENDIF}
end;
{=========================================================================}
procedure FillGradient(DC: HDC; BeginColor, EndColor: TColor;
                       nColors: integer; const aRect: TRect);
var
   BeginRGBValue : array[0..2] of Byte;
   RGBDifference : array[0..2] of integer;
   ColorBand     : TRect;
   i             : Integer;
   Red,Green,Blue: Byte;
   Brush,OldBrush: HBrush;
begin
   { Extract the begin RGB values, set the Red, Green and Blue colors }
   BeginRGBValue[0] := GetRValue(ColorToRGB(BeginColor));
   BeginRGBValue[1] := GetGValue(ColorToRGB(BeginColor));
   BeginRGBValue[2] := GetBValue(ColorToRGB(BeginColor));
   { Calculate the difference between begin and end RGB values }
   RGBDifference[0] := GetRValue(ColorToRGB(EndColor))-BeginRGBValue[0];
   RGBDifference[1] := GetGValue(ColorToRGB(EndColor))-BeginRGBValue[1];
   RGBDifference[2] := GetBValue(ColorToRGB(EndColor))-BeginRGBValue[2];
   { Calculate the color band's top and bottom coordinates, for Left To Right fills }
   ColorBand.Top := aRect.Top;
   ColorBand.Bottom := aRect.Bottom;
   { Perform the fill }
   for i := 0 to nColors-1 do
   begin
      { Calculate the color band's left and right coordinates }
      ColorBand.Left  := aRect.Left+ MulDiv(i, aRect.Right-aRect.Left, nColors);
      ColorBand.Right := aRect.Left+ MulDiv(i+1, aRect.Right-aRect.Left, nColors);
      { Calculate the color band's color }
      if (nColors > 1) then
      begin
         Red   := BeginRGBValue[0] + MulDiv(i, RGBDifference[0],nColors-1);
         Green := BeginRGBValue[1] + MulDiv(i, RGBDifference[1],nColors-1);
         Blue  := BeginRGBValue[2] + MulDiv(i, RGBDifference[2],nColors-1);
      end
      else
      begin
         { Set to the Begin Color if set to only one color }
         Red   := BeginRGBValue[0];
         Green := BeginRGBValue[1];
         Blue  := BeginRGBValue[2];
      end;
      { Create a brush with the appropriate color for this band }
      Brush := CreateSolidBrush(RGB(Red,Green,Blue));
      { Select that brush into the temporary DC. }
      OldBrush := SelectObject(DC, Brush);
      try
         { Fill the rectangle using the selected brush -- PatBlt is faster than FillRect }
         PatBlt(DC, ColorBand.Left, ColorBand.Top, ColorBand.Right-ColorBand.Left, ColorBand.Bottom-ColorBand.Top, PATCOPY);
      finally
         { Clean up the brush }
         SelectObject(DC, OldBrush);
         DeleteObject(Brush);
      end;
   end;
end;
{=========================================================================}
procedure FillSolid(DC: HDC; Color: TColor; const aRect: TRect);
var
  Brush, OldBrush: HBrush;
begin
   Brush := CreateSolidBrush(Color);
   OldBrush := SelectObject(DC, Brush);
   try
      PatBlt(DC, aRect.Left, aRect.Top,
                 aRect.Right-aRect.Left,
                 aRect.Bottom-aRect.Top, PATCOPY);
   finally
      Brush := SelectObject(DC, OldBrush);
      DeleteObject(Brush);
   end;
end;
{=========================================================================}
function WinExecAndWaitEx(FileName: TFileName; TimeOut: DWORD): Boolean;
var
   {$IFDEF WIN32}
   StartupInfo: TStartupInfo;
   ProcessInfo: TProcessInformation;
   ExCode,Res : DWORD;
   {$ELSE}
   hAppInstance: THandle;
   Msg         : TMsg;
   aBuf        : array[0..255] of Char;
   {$ENDIF}
begin
   Result := False;
   {$IFNDEF WIN32}
   hAppInstance := WinExec(StrPCopy(aBuf, FileName), SW_NORMAL);
   if (hAppInstance < HINSTANCE_ERROR) then exit
   else
   repeat
      while PeekMessage(Msg, 0, 0, 0, pm_Remove) do
      begin
        TranslateMessage(Msg);
        DispatchMessage(Msg);
      end;
   until (GetModuleUsage(hAppInstance) = 0);
   Result := True;
   {$ELSE}
   FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
   with StartupInfo do
   begin
      cb := SizeOf(TStartupInfo);
      dwFlags := STARTF_USESHOWWINDOW;
      wShowWindow := SW_NORMAL;
   end;
   if CreateProcess(nil,PChar(FileName),nil,nil,False,NORMAL_PRIORITY_CLASS,
                    nil,nil,StartupInfo,ProcessInfo) then
   begin
      Res := WaitforSingleObject(ProcessInfo.hProcess, TIMEOUT);
      if (Res = WAIT_TIMEOUT) then
      begin
         TerminateProcess(ProcessInfo.hProcess,0);
         CloseHandle(ProcessInfo.hProcess);
         Result := False;
      end
      else
      begin
         GetExitCodeProcess(ProcessInfo.hProcess, ExCode);
         CloseHandle(ProcessInfo.hProcess);
         Result := True;
      end;
   end;
   {$ENDIF}
end;
{=========================================================================}
function WinExecAndWait(FileName: TFileName): Boolean;
begin
   Result := WinExecAndWaitEx(FileName,INFINITE);
end;
{=========================================================================}
procedure TimeDecode(Time: Longint; var Hour, Min, Sec, MSec: Word);
Var
   MinCount, MSecCount: Word;
begin
   if Time > 0 then
   begin
     DivMod32(Time, 60000, MinCount, MSecCount);
     DivMod32(MinCount, 60, Hour, Min);
     DivMod32(MSecCount, 1000, Sec, MSec);
   end
   else
   begin
      Hour := 0;
      Min := 0;
      Sec := 0;
      MSec := 0;
   end;
end;
{=========================================================================}
function TimeToMask(Time: Longint): string;
begin
   Result := Format('%2.2d%2.2d%5.5d',
                    [Time div 3600000,
                     Time mod 3600000 div 60000,
                     Time mod 60000]);
end;
{=========================================================================}
function MaskToTime(Mask: string): Longint;
begin
   Result := StrToIntDef(Mask, 0);
   Result := (Result div 10000000)*3600000+
             ((Result mod 10000000) mod 100000) +
             ((Result mod 10000000) div 100000) * 60000;
end;
{=========================================================================}
function CheckFloat(const S: string): string;
var
   i: integer;
begin
   Result := S;
   for i := 1 to Length(Result) do
   begin
      if (Result[i] in ['.',',',';']) and
         (Result[i] <> DecimalSeparator) then
          Result[i] := DecimalSeparator;
   end;
end;
{$IFDEF WIN32}
{=========================================================================}
function TimeToString64Ex(Time: int64; MSec: Boolean): string;
begin
   if MSec then
   begin
      if Time >= 86400000 then
         Result := Format('%d:%2.2d:%2.2d:%2.2d.%3.3d',[int64Div32(Time,86400000),
                                                        int64Div32(int64Mod32(Time,86400000),3600000),
                                                        int64Div32(int64Mod32(Time,3600000),60000),
                                                        int64Div32(int64Mod32(Time,60000),1000),
                                                        int64Mod32(Time,1000)])
      else if Time >= 3600000 then
         Result := Format('%d:%2.2d:%2.2d.%3.3d',[int64Div32(Time,3600000),
                                                  int64Div32(int64Mod32(Time,3600000),60000),
                                                  int64Div32(int64Mod32(Time,60000),1000),
                                                  int64Mod32(Time,1000)])
      else
         Result := Format('%d:%2.2d.%3.3d',[int64Div32(Time,60000),
                                            int64Div32(int64Mod32(Time,60000),1000),
                                            int64Mod32(Time,1000)]);
   end
   else
   begin
      if Time >= 86400000 then
         Result := Format('%d:%2.2d:%2.2d:%2.2d',[int64Div32(Time,86400000),
                                                  int64Div32(int64Mod32(Time,86400000),3600000),
                                                  int64Div32(int64Mod32(Time,3600000),60000),
                                                  int64Div32(int64Mod32(Time,60000),1000)])
      else if Time >= 3600000 then
         Result := Format('%d:%2.2d:%2.2d',[int64Div32(Time,3600000),
                                            int64Div32(int64Mod32(Time,3600000),60000),
                                            int64Div32(int64Mod32(Time,60000),1000)])
      else
         Result := Format('%d:%2.2d',[int64Div32(Time,60000),
                                      int64Div32(int64Mod32(Time,60000),1000)]);
   end;
end;
{=========================================================================}
function TimeToString64(LowTime,HighTime: Cardinal; MSec: Boolean): string;
var
   Time: int64;
begin
   asm
      mov  dword ptr Time[0], eax
      mov  dword ptr Time[4], edx
   end;
   Result := TimeToString64Ex(Time, MSec);
end;
{$ENDIF}
{=========================================================================}
function TimeToStringEx(Time: MM_int64; MSec: Boolean): string;
begin
   if MSec then
   begin
      {$IFDEF DELPHI4}
      if Time >= 86400000 then
         Result := Format('%d:%2.2d:%2.2d:%2.2d.%3.3d',[Time div 86400000,
                                                       (Time mod 86400000) div 3600000,
                                                       (Time mod 3600000) div 60000,
                                                       (Time mod 60000) div 1000,
                                                       Time mod 1000])
      else
      {$ENDIF}
      if Time >= 3600000 then
         Result := Format('%d:%2.2d:%2.2d.%3.3d',[Time div 3600000,
                                                 (Time mod 3600000) div 60000,
                                                 (Time mod 60000) div 1000,
                                                 Time mod 1000])
      else
         Result := Format('%d:%2.2d.%3.3d',[Time div 60000,
                                           (Time mod 60000) div 1000,
                                           Time mod 1000]);
   end
   else
   begin
      {$IFDEF DELPHI4}
      if Time >= 86400000 then
         Result := Format('%d:%2.2d:%2.2d:%2.2d',[Time div 86400000,
                                                  (Time mod 86400000) div 3600000,
                                                  (Time mod 3600000) div 60000,
                                                  (Time mod 60000) div 1000])
      else
      {$ENDIF}
      if Time >= 3600000 then
         Result := Format('%d:%2.2d:%2.2d',[Time div 3600000,
                                           (Time mod 3600000) div 60000,
                                           (Time mod 60000) div 1000])
      else
         Result := Format('%d:%2.2d',[Time div 60000,
                                     (Time mod 60000) div 1000]);
   end;
end;
{=========================================================================}
function TimeToString(Time: MM_int64): string;
begin
   Result := TimeToStringEx(Time,True);
end;
{=========================================================================}
function StrToFloatEx(S: string; Limiter: Char): Extended;
var
   idx: integer;
begin
   case Limiter of
        ',': idx := Pos('.',S);
        '.': idx := Pos(',',S);
        else idx := -1;
   end;
   if (idx > 0) then
   begin
      if (Limiter = '.') then
          S[idx] := '.'
      else
          S[idx] := ',';
   end;
   Result:= StrToFloat(S);
end;
{=========================================================================}
function DBToLin(DB: Float): Float;
begin
   Result := pow(10,DB/20);
end;
{=========================================================================}
function LinToDB(lin: Float): Float;
begin
   if lin < 1.0e-6 then Result := -120
   else Result := log10(abs(lin))*20;
end;
{=========================================================================}
function DBToVolume(DB: Float; Base: Longint): Longint;
begin
   { if (DB = Base) then
       Result := Base
   else
   }
       Result := Round(Base/pow(10,-DB/20));
end;
{=========================================================================}
function VolumeToDB(Volume, Base: Longint): Float;
begin
   if (Volume = 0) then Result := -110.0
   else
   begin
      Result := Log10(abs(Volume)/Max(Base,1))*20;
   end;
end;
{=========================================================================}
function VolumeToStringShort(Volume, Base: Longint; Precision: integer): string;
var
   Value: Float;
begin
   if (Volume = 0) then Result := '-Inf'
   else
   begin
      Value := Log10(abs(Volume)/Max(Base,1))*20;
      Result := Format('%2.*f',[Precision,Value]);
   end;
end;
{=========================================================================}
function VolumeToString(Volume, Base: Longint; Precision: integer): string;
begin
   Result := VolumeToStringShort(Volume, Base, Precision) + ' dB';
end;
{=========================================================================}
function PanningToString(Panning, Range: Longint): string;
begin
   Result := Format('%d:%d',[(Range-Panning)*50 div Range,
                             (Panning+Range)*50 div Range]);
end;
{=========================================================================}
procedure CalcVolume(Base,Volume,Panning: Longint; var Left, Right: Longint);
begin
   if Panning > 0 then
   begin
      Left  := MulDiv((Base-Panning),Volume,Base);
      Right := Volume;
   end
   else
   begin
      Left := Volume;
      Right := MulDiv((Base+Panning),Volume,Base);
   end;
end;
{=========================================================================}
function CombineVolume(Vol1,Vol2,Base: Longint): Longint;
begin
   Result := Min(MulDiv(Vol1,Vol2,Base),Base);
end;
{=========================================================================}
function FormatBigNumber(dw: Longint): String;
begin
   { this is ugly... }
   if (dw >= 1000000000) then
   begin
      FmtStr(Result, '%d.%3.3d.%3.3d.%3.3d',
                     [(dw div 1000000000),
                      (dw mod 1000000000) div 1000000,
                      (dw mod 1000000) div 1000,
                      (dw mod 1000)]);
   end
   else if (dw >= 1000000) then
   begin
      FmtStr(Result, '%d.%3.3d.%3.3d',
                     [(dw div 1000000),
                      (dw mod 1000000) div 1000,
                      (dw mod 1000)]);
    end
    else if (dw >= 1000) then
    begin
       FmtStr(Result, '%d.%3.3d',
                      [(dw div 1000),
                       (dw mod 1000)]);
    end
    else
    begin
       FmtStr(Result, '%d', [dw]);
    end;
end;
{=========================================================================}
function BytesToString(Bytes: Comp): string;
var
   OldSep: Char;
begin
   OldSep := DecimalSeparator;
   DecimalSeparator := '.';
   if (Bytes >= 1024*1024*1024) then
       Result := Format('%.1f Gb',[Bytes/(1024*1024*1024)])
   else if (Bytes >= 1000*1024) then
       Result := Format('%.1f Mb',[Bytes/(1024*1024)])
   else
       Result := Format('%.1f Kb',[Bytes/1024]);
   DecimalSeparator := OldSep;
end;
{=========================================================================}
procedure DrawRubberband(Sender: TObject; aRect: TRect);
var
  DC: HDC;
  PtA, PtB: TPoint;
begin
   if Sender is TControl then
   with (Sender as TControl) do
   begin
      DC := GetDC(0);
      if (aRect.Left <> 0) or (aRect.Top <> 0) or
         (aRect.Right <> 0) or (aRect.Bottom <> 0) then
      begin
         PtA := ClientToScreen(Point(aRect.Left, aRect.Top));
         PtB := ClientToScreen(Point(aRect.Right, aRect.Bottom));
         {$IFDEF WIN32}
         if PtA.X > PtB.X then SwapLong(PtA.X,PtB.X);
         if PtA.Y > PtB.Y then SwapLong(PtA.Y,PtB.Y);
         {$ELSE}
         if PtA.X > PtB.X then SwapInt(PtA.X,PtB.X);
         if PtA.Y > PtB.Y then SwapInt(PtA.Y,PtB.Y);
         {$ENDIF}
         DrawFocusRect(DC, Rect(PtA.X, PtA.Y, PtB.X, PtB.Y));
      end;
      ReleaseDC(0,DC);
   end;
end;
{=========================================================================}
procedure DrawRubberLineEx(Sender: TObject; aRect: TRect; Pen: HPEN; ROP: DWORD);
var
  DC: HDC;
  PtA, PtB: TPoint;
begin
   if Sender is TControl then
   with (Sender as TControl) do
   begin
      DC := GetDC(0);
      Pen := SelectObject(DC,Pen);
      SetRop2(DC,ROP);
      if (aRect.Left <> 0) or (aRect.Top <> 0) or
         (aRect.Right <> 0) or (aRect.Bottom <> 0) then
      begin
         PtA := ClientToScreen(Point(aRect.Left, aRect.Top));
         PtB := ClientToScreen(Point(aRect.Right, aRect.Bottom));
         {$IFDEF WIN32}
         MoveToEx(DC,PtA.X,PtA.Y,nil);
         {$ELSE}
         MoveToEx(DC,PtA.X,PtA.Y,nil);
         {$ENDIF}
         LineTo(DC,PtB.X,PtB.Y);
      end;
      SelectObject(DC,Pen);
      ReleaseDC(0,DC);
   end;
end;
{=========================================================================}
procedure DrawRubberLine(Sender: TObject; aRect: TRect);
begin
   DrawRubberLineEx(Sender,aRect,GetStockObject(WHITE_PEN),R2_XORPEN);
end;
{=========================================================================}
{ Align: 0: Left, 1: Right: 2: Vertikal                                   }
procedure TextOutAligned(Canvas: TCanvas; X, Y: integer; Text: String;
                         FontName: PChar; FontSize: integer; Align: Byte);
var
   DC: THandle;
   HFont, OldFont: integer;
   Extent: TSize;
   Orientation: Word;
begin
   DC := Canvas.Handle;
   if Align = 2 then
      Orientation := 90
   else
      Orientation := 360;
   if _Win2K_ or _WinXP_ then
      FontSize := -(FontSize-1);
      
   HFont := CreateFont(FontSize,0,Orientation*10,0,fw_normal,0,0,0,1,4,$10,2,4,FontName);
   OldFont := SelectObject(DC, HFont);
   GetTextExtentPoint(DC, @Text[1], Length(Text), Extent);
   case Align of
       0: begin { left aligned }
             dec(Y, Extent.cY div 2);
          end;
       1: begin { right aligned }
             dec(X, Extent.cX);
             dec(Y, Extent.cY div 2);
          end;
       2: begin { vertikal aligned }
             dec(X, Extent.cY div 2);
             inc(Y, Extent.cX);
          end;
   end;
   Text := Text + #0;
   TextOut(DC, X, Y, @Text[1], Length(Text)-1);
   SelectObject(DC, OldFont);
   DeleteObject(HFont);
end;
{=========================================================================}
function GlobalAllocMem(Size: Longint): Pointer;
begin
   Result := GlobalAllocPtr(GPTR, Size);
   if (Result = nil) then OutOfMemoryError;
end;
{=========================================================================}
procedure GlobalReAllocMem(var p: Pointer; Size: Longint);
begin
   GlobalFreeMem(p);
   p := GlobalAllocMem(Size);
end;
{=========================================================================}
procedure GlobalFreeMem(var p: Pointer);
begin
   if (p <> nil) then
   begin
      GlobalFreePtr(p);
      p := nil;
   end;
end;
{=========================================================================}
function GlobalMemSize(const p: Pointer): Longint;
begin
   if (p <> nil) then
   begin
      {$IFDEF WIN32}
      Result := GlobalSize(GlobalHandle(p));
      {$ELSE}
      Result := GlobalSize(GlobalHandle(SELECTOROF(p)));
      {$ENDIF}
   end
   else Result := 0;
end;
{=========================================================================}
function SearchParamStr(Switch: string): Boolean;
var
   i,idx: integer;
   S: string;
begin
   for i := 1 to ParamCount do
   begin
      S := ParamStr(i);
      idx := Pos(':',S);
      if (idx > 0) then
          S := Copy(S,1,idx-1);
      if (S<> '') and (S[1] in ['-', '/']) and
         (CompareText(Copy(S, 2, Length(Switch)), Switch) = 0) and
         (Length(Switch) = Length(S)-1) then
      begin
         Result := True;
         Exit;
      end;
   end;
   Result := False;
end;
{=========================================================================}
procedure WinYield(Wnd: THandle);
var
   msg: TMsg;
begin
   while PeekMessage(Msg, Wnd, 0, 0, PM_REMOVE) do
   begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
   end;
end;
{=========================================================================}
function DesignMode: Boolean;
var
   ExeName: array[0..260] of Char;
begin
   { in DesignMode? }
   GetModuleFileName(0, ExeName, sizeOf(ExeName));
   StrUpper(ExeName);
   if (StrPos(ExeName, 'DELPHI32') <> nil) or
      (StrPos(ExeName, 'BCB') <> nil) or
      (StrPos(ExeName, '.DCP') <> nil) or
      (StrPos(ExeName, '.BPL') <> nil) or
      (StrPos(ExeName, '.DCL') <> nil) or
      (StrPos(ExeName, '.CCL') <> nil) then
       Result := True
   else
       Result := False;
end;
{$IFDEF CHECK_REGISTERED}
{$IFDEF BUILD_ACTIVEX}
   {$I MMREGAX.INC}
{$ENDIF}
{$ENDIF}
{=========================================================================}
procedure RegisterPackage(const Pack: string);
begin
   {$IFDEF BUILD_ACTIVEX} {$IFDEF CHECK_REGISTERED}
   _RegisterPackage(Pack);
   {$ENDIF} {$ENDIF}
end;
{=========================================================================}
procedure RegisterComponent(Code: Longint; Control: TComponent; Text: string);
begin
   { only a dummy call to write portable code }
end;
{=========================================================================}
function ComponentRegistered(Code: Longint; Control: TComponent; Text: string): Longint;
begin
   Result := 0;
   {$IFDEF BUILD_ACTIVEX} {$IFDEF CHECK_REGISTERED}
   Result := _CheckComponent(Code,Control,Text);
   {$ENDIF} {$ENDIF}
end;
{=========================================================================}
function PackageRegistered(Pack: string): integer;
begin
   Result := 0;
   {$IFDEF BUILD_ACTIVEX} {$IFDEF CHECK_REGISTERED}
   Result := _CheckPackage(Pack);
   {$ENDIF} {$ENDIF}
end;
const
     FailCount : Longint = 0;
     AboutCount: Longint = 0;
     hAboutSem : THandle = 0;
{=========================================================================}
procedure RegisterFailed(Code: Longint; Control: TComponent; Text: string);
{$IFDEF BUILD_ACTIVEX}
var
   SemCount: Longint;
   function EnumWindowsProc(hwnd: HWND; lParam: LPARAM): Boolean; stdcall;
   var
      CaptionText: array[0..80] of Char;
   begin
      GetWindowText(hwnd, CaptionText, sizeOf(CaptionText)-1);
      if (StrPos(CaptionText, 'Delphi') <> nil) or
         (StrPos(CaptionText, 'C++ Builder') <> nil) or
         (StrPos(CaptionText, 'Microsoft Visual Basic') <> nil) or
         (StrPos(CaptionText, 'Microsoft Developer Studio') <> nil) then
      begin
         Boolean(Pointer(lParam)^) := True;
         Result := False;
      end
      else
          Result := True;
   end;
   function FindValidIDE: Boolean;
   var
      IDEFound: Boolean;
   begin
      IDEFound := False;
      Result := EnumWindows(@EnumWindowsProc,LPARAM(@IDEFound));
   end;
{$ENDIF}
begin
   {$IFDEF BUILD_ACTIVEX}
   if (FailCount = 0) then
   begin
      //it should be 0.
      hAboutSem := OpenSemaphore(EVENT_ALL_ACCESS, False, '_MMToolsX_');
      if (hAboutSem = 0) then
          hAboutSem := CreateSemaphore(nil, 0, MaxInt, '_MMToolsX_');
      if (hAboutSem <> 0) then
      begin
         ReleaseSemaphore(hAboutSem,1,@SemCount);
         if not FindValidIDE or (SemCount mod 10 = 0) then
            Show_EvalAboutBox(1);
      end;
   end;
   inc(FailCount);
   {$ELSE}
   if (FailCount = 0) then
       Application.MessageBox('Initialization Error',
                              'Multimedia Tools', MB_OK);
   if DesignMode then
      inc(FailCount)
   else
      Halt;
   {$ENDIF}
end;
{$IFDEF WIN32}
{$IFNDEF DELPHI3}
{-----------------------------------------------------------------------------}
function SysErrorMessage(ErrorCode: Integer): string;
var
   Len     : Integer;
   Buffer  : array[0..255] of Char;
begin
   Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
                        FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode,
                        GetThreadLocale, Buffer, SizeOf(Buffer), nil);
   while (Len > 0) and (Buffer[Len - 1] in [#0..#32, '.']) do Dec(Len);
   SetString(Result, Buffer, Len);
end;
{ TODO: resource ids }
const
    SWin32Error = 'Win32 Error. Code: %d.'#10'%s';
    SUnkWin32Error = 'A Win32 API function failed';
{-----------------------------------------------------------------------------}
procedure RaiseLastWin32Error;
var
   LastError: DWORD;
   Error    : EWin32Error;
begin
   LastError := GetLastError;
   if LastError <> ERROR_SUCCESS then
      Error := EWin32Error.CreateFmt(SWin32Error, [LastError,SysErrorMessage(LastError)])
   else
      Error := EWin32Error.Create(SUnkWin32Error);
   Error.ErrorCode := LastError;
   raise Error;
end;
{-----------------------------------------------------------------------------}
function Win32Check(RetVal: BOOL): BOOL;
begin
   if not RetVal then
      RaiseLastWin32Error;
   Result := RetVal;
end;
{$ENDIF}
{$ENDIF}
{$IFNDEF USEDLL}
   {$I MMUTILS.INC}
{$ELSE}
var
   ErrorMode      : Cardinal = 0;
   GetDeviceID    : function: Longint;
   GetDeviceStatus: function(Device: Longint): Longint;
{$ENDIF}
{------------------------------------------------------------------------}
procedure NewExitProc; Far;
begin
   if MMUTILDLLHandle <> 0 then
      FreeLibrary(MMUTILDLLHandle);
   if (SBuf <> nil) then GlobalFreePtr(SBuf);
   {$IFDEF WIN32}
   DeleteCriticalSection(TransSection);
   {$ENDIF}
end;
{=========================================================================}
function FindIDERunning: Boolean;
var
  IDEHWnd : THandle;
  CaptionText: array[0..80] of Char;
  {$IFDEF TRIAL}
  h: THandle;
  {$ENDIF}
begin
   Result := False;
   {$IFDEF TRIAL}
   (*
   h := LoadLibrary(MMUtilDLLKeyName);
   if (h <> 0) then
   begin
      {$IFDEF WIN32}
      {$IFDEF TRIAL}
      {$DEFINE _HACK3}
      {$I MMHACK.INC}
      {$ENDIF}
      {$ENDIF}
      FreeLibrary(h);
      Result := True;
   end
   else
   *)
   {$ENDIF}
   begin
      { Delphi or C++Builder running? }
      IDEHWnd:= FindWindow('TAppBuilder', Nil);
      if (IDEHWnd <> 0) then
      begin
         GetWindowText(IDEHWnd, CaptionText, sizeOf(CaptionText)-1);
         StrUpper(CaptionText);
         if (StrPos(CaptionText, 'DELPHI') <> nil) or
            (StrPos(CaptionText, 'C++BUILDER') <> nil) then
             Result := True;
      end;
   end;
end;
{$IFDEF WIN32}
{========================================================================}
procedure InitDriveSpacePtr;
var
  Kernel: THandle;
begin
  Kernel := GetModuleHandle(Windows.Kernel32);
  if Kernel <> 0 then
     @_GetDiskFreeSpaceEx := GetProcAddress(Kernel, 'GetDiskFreeSpaceExA');
  if not Assigned(_GetDiskFreeSpaceEx) then
     _GetDiskFreeSpaceEx := @BackfillGetDiskFreeSpaceEx;
end;
{$ENDIF}
{========================================================================}
procedure InitMMUtils;
{$IFDEF USEDLL}
var
   P: Pointer;
{$ENDIF}
begin
   {$IFDEF USEDLL}
   ErrorMode := SetErrorMode(SEM_NoOpenFileErrorBox);
   try
      GetDeviceID:= nil;
      if (GetModuleHandle(MMUTILDLLName) = 0) then
      begin
         (*MMUTILDLLHandle := LoadLibrary(MMUTILDLLKeyName);
         P := GetProcAddress(MMUTILDLLHandle,'_GetDeviceID_');
         if (P = nil) and (MMUTILDLLHandle <> 0) then
         begin
            FreeLibrary(MMUTILDLLHandle);
            MMUTILDLLHandle := 0;
         end;
         if MMUTILDLLHandle < HINSTANCE_ERROR then
         *)   MMUTILDLLHandle := LoadLibrary(MMUTILDLLName);
      end;
      if MMUTILDLLHandle >= HINSTANCE_ERROR then
      begin
         {$IFNDEF WIN32}
         AddExitProc(NewExitProc);
         {$ENDIF}
         @GetDeviceID        := GetProcAddress(MMUTILDLLHandle,'_GetDeviceID');
         @GetDeviceStatus    := GetProcAddress(MMUTILDLLHandle,'_GetDeviceStatus');
         @IDERunning         := GetProcAddress(MMUTILDLLHandle,'_IDERunning');
         @CheckTime          := GetProcAddress(MMUTILDLLHandle,'_CheckTime');
         @SwapSmall          := GetProcAddress(MMUTILDLLHandle,'_SwapSmall');
         @SwapInt            := GetProcAddress(MMUTILDLLHandle,'_SwapInt');
         @SwapLong           := GetProcAddress(MMUTILDLLHandle,'_SwapLong');
         @Min                := GetProcAddress(MMUTILDLLHandle,'_Min');
         @Max                := GetProcAddress(MMUTILDLLHandle,'_Max');
         @MinMax             := GetProcAddress(MMUTILDLLHandle,'_MinMax');
         @Limit              := GetProcAddress(MMUTILDLLHandle,'_Limit');
         @InMinMax           := GetProcAddress(MMUTILDLLHandle,'_InMinMax');
         @InRange            := GetProcAddress(MMUTILDLLHandle,'_InRange');
         @incHuge            := GetProcAddress(MMUTILDLLHandle,'_incHuge');
         @GlobalFillMem      := GetProcAddress(MMUTILDLLHandle,'_GlobalFillMem');
         @GlobalFillLong     := GetProcAddress(MMUTILDLLHandle,'_GlobalFillLong');
         @GlobalMoveMem      := GetProcAddress(MMUTILDLLHandle,'_GlobalMoveMem');
         @GlobalCmpMem       := GetProcAddress(MMUTILDLLHandle,'_GlobalCmpMem');
         {$IFDEF WIN32}
         CheckParam1 := @OpenSemaphore;
         CheckParam2 := @GetVolumeInformation;
         {$ENDIF}
      end
      else
      begin
         MessageDlg('Unable to load '+StrPas(MMUtilDLLName), mtError, [mbOK],0);
         Halt;
      end;
   finally
      SetErrorMode(ErrorMode);
   end;
   {$ELSE}
   SwapSmall          := _SwapSmall;
   SwapInt            := _SwapInt;
   SwapLong           := _SwapLong;
   Min                := _Min;
   Max                := _Max;
   MinMax             := _MinMax;
   Limit              := _Limit;
   InMinMax           := _InMinMax;
   InRange            := _InRange;
   incHuge            := _incHuge;
   GlobalFillMem      := _GlobalFillMem;
   GlobalFillLong     := _GlobalFillLong;
   GlobalMoveMem      := _GlobalMoveMem;
   GlobalCmpMem       := _GlobalCmpMem;
   {$ENDIF}
end;
{$IFDEF TRIAL}
var
   aBuf: array[0..256] of Char;
{$ENDIF}
{========================================================================}
initialization
     {$IFDEF WIN32}
     InitializeCriticalSection(TransSection);
     {$ENDIF}
     {$IFDEF TRIAL}
     if not FindIDERunning then
     begin
        Application.MessageBox(StrPCopy(aBuf,'IDE not found. Please register !'),
                                             'Multimedia Tools', MB_OK);
        Halt;
     end;
     {$ENDIF}
     InitMMUtils;
     {$IFDEF TRIAL}
     if assigned(GetDeviceID) then InitCode := GetDeviceID;
     if (InitCode = 0) then
         raise Exception.Create('Initialization Error');
     GetDeviceStatus(InitCode);
     Randomize;
     {$ENDIF}
     SBuf := GlobalAllocMem(50000);
     FillChar(SBuf^,50000,$FF);
     _Win95_    := HaveWin95;
     _Win98_    := HaveWin98;
     _WinME_    := HaveWinME;
     _WinNT3_   := HaveWinNT;
     _WinNT4_   := HaveWinNT4;
     _Win2K_    := HaveWin2K;
     _WinXP_    := HaveWinXP;
     _Win9x_    := _Win95_ or _Win98_ or _WinME_;
     _WinNT_    := _WinNT3_ or _WinNT4_ or _Win2K_ or _WinXP_;
     _WinNT_NEW_:= _WinNT4_ or _Win2K_ or _WinXP_;
     {$IFDEF WIN32}
     _CPU_      := GetCPUType;
     _MMX_      := (GetCPUFeatures and $800000 <> 0);
     _USECPUEXT_:= True;
      InitDriveSpacePtr;
     {$ENDIF}
{$IFDEF WIN32}
Finalization
    NewExitProc;
{$ENDIF}
end.

						