vgutils.pas

大家是不是为不知道如何在VB学到绝地程序

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff Delphi VCL Library         }
{         General-purpose utility routines              }
{                                                       }
{         Copyright (c) 1997, 2000                      }
{                                                       }
{*******************************************************}

{$I VG.INC }
{$D-,L-}

unit vgUtils;

interface
uses Windows, {$IFNDEF _D3_}Ole2,{$ENDIF} SysUtils, TypInfo, Classes, vgSystem;

type
  EMessage            = class(Exception);
  EWarningMessage     = class(EMessage);
  EInformationMessage = class(EMessage);
  EFileOperation      = class(Exception);

  TMessageProc = procedure(const Msg: string);
  TWriteLogProc = procedure(const FileName, Msg: string);

  TComponentCallback = procedure(Instance: TComponent; Data: Pointer);

  TCompareItems = function (Data: Pointer; Item1, Item2: Pointer): Integer;
  TExchangeItems = procedure (Data: Pointer; Index1, Index2: Integer);

{ --- Exceptions }
procedure CheckCondition(Condition: Boolean; EClass: ExceptClass; const EMessage: string);
{ Raises exception if not Condition }

procedure InformationMessage(const Msg: string);
{ Raises EInformationMessage exception with message }

procedure WarningMessage(const Msg: string);
{ Raises EWarningMessage exception with message }

{ --- Math }
function Max(A, B: Integer): Integer;
function Min(A, B: Integer): Integer;
{ Returns min or max value accordinally }

function RangeCheck(Value, Min, Max: Integer): Integer;
{ Controls that Value betweeen Min and Max and increase or decrease Result accordinaly }

function RoundFloat(Value: Extended; Digits: Integer): Extended;
{ Rounds Value to Digits digits after decimal point }

function CompareInteger(Value1, Value2: Integer): Integer;
function CompareDWord(Value1, Value2: DWord): Integer;
{$IFDEF _D4_}
function CompareInt64(const Value1, Value2: Int64): Integer;
function CompareUInt64(const Value1, Value2: Int64): Integer;
{$ENDIF}
{ Compares two given Integer values }

function CompareFloat(Value1, Value2: Extended; Digits: Integer): Integer;
{ Compares two given values and returns result of comparision }
{ Return values are the same as in CompareText function       }

function IsEqualFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
function IsAboveFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
function IsBehindFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
function IsAboveEqualFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
function IsBehindEqualFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
{ Compares two values up to Digits digits after decimal point }

function StrToFloatDef(const Value: string; Default: Extended): Extended;
{ Converts Value into extended. }

{ --- Memory blocks }
function CompareMem(P1, P2: Pointer; Length: Integer): Boolean;
{ Compares to blocks of memory }

function FindInteger(Value: Integer; const Buff; Count: Integer): Integer;
{ Searches for Value in the Buff array. Returns index of Value or -1 if not found }

function CompareChars(const Buffer1, Buffer2; Count: Integer): Integer;
{ Compares two block of chars }
{ Return values are the same as in CompareText function       }

procedure ZeroMem(pBuff: Pointer; Count: Integer);
{ Initializes block of memory with zeros }

{ --- String routines }
function Like(const Source, Template: String): Boolean;

function Bin2Hex(Bytes: PChar; Count: Integer): string;
procedure Hex2Bin(Hex: string; Bytes: PChar; Count: Integer);
{ Converts binary buffer into string and backward }

procedure AddDelimeted(var S: string; const SubStr, Delimeter: string);
function GetListString(Fmt: string; Strings: TStrings): string;
function ExtractDelimeted(const S, Delimeter: string; var Pos: Integer): string;
function ExtractDelimetedWord(const S, Delimeter: string; Number: Integer; var Pos: Integer): string;
procedure GetDelimetedStrings(const S, Delimeter: string; List: TStrings);

function PosText(const SubStr, Source: string): Integer;
{ Searches postionion of SubStr without case sensitivity }

function ReplaceStr(const S, Srch, Replace: string): string;
{ Repleaces Srch substrings with Replace }

function WordCount(const S: string; const WordDelims: TCharSet): Integer;
{ Returns a number of words delimeted with WordDelims }

function WordPosition(const N: Integer; const S: string; const WordDelims: TCharSet): Integer;
{ Returns a position of word number N in the string S }

function ExtractWord(N: Integer; const S: string; const WordDelims: TCharSet): string;
{ Returns a word number N in the string S }

procedure WideCharToNames(Names: PChar; NameCount: Byte; var WideNames: TNames; var Size: Word);
{ Converts pointer to wide char to names }

{ --- Macro }
function ForEachString(Strings: TStrings; const Separator, StringMacro, Macro: string): string;
{ Expands macro Macro for each string from Strings.           }
{ Expanded macroses are concatenated with Separator separator }
{ Each occurence of StringMacro in Macro string is replaced   }
{ by string from Strings.                                     }

{ --- Nill-able TLists }
function ListAdd(var List: TList; Item: Pointer): Pointer;
{ Adds Item to list List. If List is nil than calls TList constructor }

procedure ListClear(var List: TList);
{ Macro for ListDestroy }

function ListCount(List: TList): Integer;
{ Returns count of items in List or zero if List = nil }

function ListDelete(var List: TList; Index: Integer): Pointer;
{ Deletes from List. If List is empty than destroys List }

procedure ListDestroy(var List: TList);
{ Destroys List and set it to nil }

procedure ListDestroyAll(var List: TList);
{ Destroys all items from TList as they are TObject descendents and List object }

procedure ListDestroyObjects(List: TList);
{ Destroys all items from TList as they are TObject descendents }
{ and clears the List }

procedure ListDestroyObjectsAll(var List: TList);
{ ListDestroyAll macro }

procedure ListFreeMem(List: TList);
{ Destroys all items from TList as they pointers allocated with GetMem }
{ and clears the List }

procedure ListFreeMemAll(var List: TList);
{ Destroys all items from TList as they pointers allocated with GetMem }
{ and frees the List }

procedure ListSort(List: TList; Compare: TListSortCompare);
{ Sorts given list }

procedure ListError(Index: Integer);
{ raises EListError exception }

function ListIndexOf(List: TList; Item: Pointer): Integer;
{ Returns index of Item in List }

procedure ListInsert(var List: TList; Index: Integer; Item: Pointer);
{ Inserts Item in List }

function ListItem(List: TList; Index: Integer): Pointer;
{ Returns item of List raises exception if List = nil }

function ListRemove(var List: TList; Item: Pointer): Pointer;
{ Removes Item from List. If List is empty than destroys List }

function ListRemoveLast(var List: TList): Pointer;
{ Same as ListRemove, but removes last item from List }

procedure QuickSortList(AList: TList; DataCompare, DataExchange: Pointer;
  Compare: TCompareItems; AExchange: TExchangeItems);
{ Sorts given List }

procedure ListAssign(var Dest: TList; Source: TList);
{ Copies contents of Source into Dest }

function ListCheck(var List: TList): TList;
{ Checks that List exists and creates it if not }

{ --- TStrings }
procedure StringsAssignTo(List: TStrings; const Strings: Array of string);
procedure ArrayAssignTo(List: TStrings; var Strings: Array of string);
{ Assings a strings from List to Strings elements and backward }

function StringsHistoryInsertObject(List: TStrings; Index: Integer;
  const Value: string; AObject: TObject; MaxCount: Integer): Integer;

function StringsHistoryInsert(List: TStrings; Index: Integer;
  const Value: string; MaxCount: Integer): Integer;

function StringsHistoryAddObject(List: TStrings; const Value: string;
  AObject: TObject; MaxCount: Integer): Integer;

function StringsHistoryAdd(List: TStrings; const Value: string; MaxCount: Integer): Integer;

{ --- Components and streams }
function IsClass(AClass: TClass; ParentClass: TClass): Boolean;
{ Returns True if AClass is ParentClass descendent }

procedure RegisterComponent(Instance: TComponent);
{ Register component Instance and all their recursive childrens             }
{ through RegisterClass procedure to make sure it can be readed from stream }

procedure CopyProps(Src: TComponent; Dst: TComponent);
{ Copies Src component and all their recursive childrens to Dst component   }
{ Note that Src.Owner cannot be nil                                         }

function CreateCloneOwner(Src: TComponent; AOwner: TComponent): TComponent;
{ Creates a clone of Src component with the Owner AOwner }

function CreateClone(Src: TComponent): TComponent;
{ Creates a clone of Src component with the same Owner }

function CreateComponentOwnerNeeded(var Instance; ComponentClass: TComponentClass;
  AOwner: TComponent): TComponent;
{ Creates a component with Owner if Instance is not assigned yet }

function CreateComponentNeeded(var Instance; ComponentClass: TComponentClass): TComponent;
{ Creates a component without Owner if Instance is not assigned yet }

function CreateCloneOwnerNeeded(var Instance; Src: TComponent; AOwner: TComponent): TComponent;
{ Creates a clone of Src component with the Owner AOwner if Instance is not Assigned and returns Instance }

function CreateCloneNeeded(var Instance; Src: TComponent): TComponent;
{ Creates a clone of Src component with the Owner AOwner if Instance is not Assigned and returns Instance }

procedure FreeObject(var Obj);
{ Frees Obj and initialize it to zero }

procedure CopyMethodProps(Src, Dst: TObject);
{ Copies method properties from Src to Dst objects }

function UniqueName(Instance: TComponent; const Name: string; Owner: TComponent): string;
{ Returns unique name to component Instance to make sure it valid for Owner }

procedure WriteAndRead(Src: TComponent; Dst: TComponent); { obsolete }
{ Macro for CopyProps procedure }

{ --- For Each component }
procedure ForComponents(AComponents: array of TComponent;
  Callback: TComponentCallback; Data: Pointer);
{ ForEach Callback }

procedure ForEachComponent(Instance: TComponent;
  ComponentClass: TComponentClass; Callback: TComponentCallback; Data: Pointer; Children: Boolean);
{ Recurrent Callback }

{ --- IniFiles and logs }
function AppPathFileName(FileName: TFileName): TFileName;
{ Returns the file name concated from application path and FileName }

procedure WriteBoolean(const IniFile, IniSection, Ident: string; const Value: Boolean; UseRegistry: Boolean);
procedure WriteFloat(const IniFile, IniSection, Ident: string; const Value: Double; UseRegistry: Boolean);
procedure WriteInteger(const IniFile, IniSection, Ident: string; const Value: Integer; UseRegistry: Boolean);
procedure WriteString(const IniFile, IniSection, Ident, Value: string; UseRegistry: Boolean);

function ReadBoolean(const IniFile, IniSection, Ident: string; const DefValue: Boolean; UseRegistry: Boolean): Boolean;
function ReadFloat(const IniFile, IniSection, Ident: string; const DefValue: Double; UseRegistry: Boolean): Double;
function ReadInteger(const IniFile, IniSection, Ident: string; const DefValue: Integer; UseRegistry: Boolean): Integer;
function ReadString(const IniFile, IniSection, Ident, DefValue: string; UseRegistry: Boolean): string;
{ Writes/reads Value to or/from ini files or registry }

procedure AppWriteLog(const Msg: string);
{ Writes a Msg to file with file name AppFileName and .log extension }

procedure WriteLog(const FileName: TFileName; const Msg: string);
{ Writes a log message in the critical section      }
{ through WriteLogProc or DefaultWriteLog procedure }

procedure DefaultWriteLog(const FileName: TFileName; const Msg: string);
{ Writes a log message in file }

{ --- File operations support }
function GetTempFileName(const Path: TFileName): TFileName;
{ Returns the generic name of the temporary file in the TEMP dir }

function BackupFile(const FileName: TFileName): Boolean;
{ Renames file FileName to *.bak deleting old backup if exists }

procedure CheckBackupFile(const FileName: TFileName);
{ Backups file and raises an exception if an error occurs }

procedure CheckDeleteFile(const FileName: TFileName);
{ Deletes file and raises an exception if an error occurs }

procedure CheckRenameFile(const OldName, NewName: TFileName);
{ Renames file and raises an exception if an error occurs }

procedure LoadComponent(const FileName: string; Instance: TComponent);
{ Loads component properties from file }

procedure SaveStream(const FileName: string; Source: TStream);
{ Writes stream to file and backups old if needed }

procedure SaveComponent(const FileName: string; Instance: TComponent);
{ Saves component properties to file and backups old if needed }

procedure GetFileNames(const Directory, FileMask: string; Attr: Integer; FileNames: TStrings);
{ Adds all found files to FileNames }

{ --- Variant }
function NvlInteger(const Value: Variant): Integer;
function NvlFloat(const Value: Variant): Double;
function NvlDateTime(const Value: Variant): TDateTime;
function NvlString(const Value: Variant): string;
{ Functions return "zero" values when Value is Null or   }
{ when Value value is compatible with the function result }

function VarRecToVariant(VarRec: TVarRec): Variant;
{ Converts VarRec record into Variant }

function VarArrayFromConst(const Args: array of const): Variant;
{ Converts array of const into Variant array with bounds 0, High(Args) }

function VarArrayFromConstCast(const Args: array of const): Variant;
{ Converts array of pairs [Variant, Integer] into Variant array with bounds 0, High(Args) }
{ and casts each of elements to Integer varXXX }

function VarArrayCast(const Values: Variant; Args: array of Integer): Variant;
{ Args is array of pairs [Index, varType]                       }
{ Function casts each Values[Index] to varType type             }

function VarArrayOfPairs(const Args: array of const): Variant;
{ Args is array of pairs. Each pair converted into variant array. }
{ Result is variant array of variant arrays                       }

function VarArrayOfPairsCast(const Values: Variant; const Args: array of Integer): Variant;
{ Function casts second element of pair accordinally to Args }

function VarComparable(const V1, V2: Variant): Boolean;
{ Returns true if V1 can be compared with V2 }

function VarIsEqual(const V1, V2: Variant): Boolean;
{ Reruns true if V1 is comparable with V2 and equal }

procedure StringsFromVarArray(const List: Variant; Strings: TStrings);
{ Converts array of Variant into list of strings }

function VarArrayFromStrings(Strings: TStrings): Variant;
{ Converts list of strings into Variant array }

procedure EnumStrings(List: TStrings; EnumProc: TGetStrProc);
{ Enums each elemnt of List }

procedure EnumVarArray(const List: Variant; EnumProc: TGetStrProc);
{ Enums each elemnt of List }

function VarToDispatch(Instance: Variant): IDispatch;
{ Extractts IDispatch interface from interface }

procedure WriteBufferAt(Stream: TStream; const Buff; Count: Integer; Position: Integer);
{ Writes Count bytes to the Stream and restores old stream position }

{ --- Swap }
procedure SwapStrings(var Str1, Str2: string);
procedure SwapInteger(var Value1, Value2: Integer);

{ --- DateTime }
function IsLeapYear(Year: Word): Boolean;
function GetDayTable(Year: Word): PDayTable;

{ --- DLLs }
procedure PreloadLibraries(const DLLs: array of PChar; Handles: PInstance);
{ Loads DLL libraries in DLLs array for faster execution after startup }

procedure UnloadLibraries(Handles: PInstance; Count: Integer);
{ Frees DLL libraries loaded in PreloadLibraries procedure }

function RegisterServer(const DLLName: string): Boolean;
{ Registers OLE server in filename DLLName and returns True if successfull }

{ --- VMT low-level }
function GetVirtualMethodAddress(AClass: TClass; AIndex: Integer): Pointer;
{ Returns address of virtual method of AClass with index AIndex }

function SetVirtualMethodAddress(AClass: TClass; AIndex: Integer;
  NewAddress: Pointer): Pointer;
{ Updates VMT of AClass and sets new method address of method with index AIndex }

function FindVirtualMethodIndex(AClass: TClass; MethodAddr: Pointer): Integer;
{ Iterates through VMT of AClass and seeks for method MethodAddr }

{ Misc }
{$IFDEF _D3_}
function ResStr(const Ident: string): string;
{$ELSE}
function ResStr(Ident: Integer): string;
{$ENDIF}

{ Macro for loading strings from resources }

{$IFDEF _D3_}
{ --- Resourcestring }
procedure StoreResString(P: PResStringRec);
{ Saves resourcestring information }

procedure RestoreResString(P: PResStringRec);
{ Restores resourcestring information }

procedure CopyResString(Source, Dest: PResStringRec; Store: Boolean);
{ Owerwrites resourcestring information to make Dest resourcesting   }
{ the same as Source                                                 }
{ Note that if Source and Dest are in different packages you should  }
{ always restore resourcestring information before unloading package }
{ that contains Source                                               }
{$ENDIF}

function Win32Description: string;
{ Returns string like 'Windows NT 4.00 (Service Pack 4)' }

procedure GetEnvironment(Strings: TStrings);
{ Extracts environment strings and sets Strings as Values array }

function GetEnvironmentVariable(const Variable: string): string;
{ Extracts value of variable }

const
  SEMAPHORE_MODIFY_STATE    =  $0002;
  SEMAPHORE_ALL_ACCESS      =  STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0003;

{$IFNDEF _D3_}

  PROCESS_TERMINATE         =  $0001;
  PROCESS_CREATE_THREAD     =  $0002;
  PROCESS_VM_OPERATION      =  $0008;
  PROCESS_VM_READ           =  $0010;
  PROCESS_VM_WRITE          =  $0020;
  PROCESS_DUP_HANDLE        =  $0040;
  PROCESS_CREATE_PROCESS    =  $0080;
  PROCESS_SET_QUOTA         =  $0100;
  PROCESS_SET_INFORMATION   =  $0200;
  PROCESS_QUERY_INFORMATION =  $0400;
  PROCESS_ALL_ACCESS        =  STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;

{$ENDIF _D3_}

{ --- System }
function IsMainThread: Boolean;
{ Returns True if called from the main thread }

function GetProcessHandle(ProcessID: DWORD): THandle;
{ Tryies to extract process handle from ProcessID         }

{ --- TypInfo utilites }
function GetPropType(PropInfo: PPropInfo): PTypeInfo;
{ Returns type information for the given property }

procedure GetPropInfoList(List: TList; Instance: TObject; Filter: TTypeKinds);