mmutils.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]               =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  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;