vgutils.pas

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

{ Fills List with PPropInfo pointers }

var
  { Variable used in Log procedures. Default is ParamStr(0) }
  AppFileName      : string = '';

  InformationProc  : TMessageProc  = nil;
  WarningProc      : TMessageProc  = nil;

  { When assigned, called by WriteLog procedure             }
  WriteLogProc     : TWriteLogProc = nil;
 
  { Timeout for waiting for logfile to be opened }
  AppLogTimeout    : Integer       = 0;

const
  EasyArrayTypes = [varSmallInt, varInteger, varSingle, varDouble, varCurrency,
                    varDate, varBoolean, varByte];

  VariantSize: array[0..varByte] of Word  = (0, 0, SizeOf(SmallInt), SizeOf(Integer),
    SizeOf(Single), SizeOf(Double), SizeOf(Currency), SizeOf(TDateTime), 0, 0,
    SizeOf(Integer), SizeOf(WordBool), 0, 0, 0, 0, 0, SizeOf(Byte));

const
  IniFileExt       = '.ini';

implementation
uses Consts, vgVCLRes, IniFiles, Registry, Math;

var
  FLogLock: TRTLCriticalSection;

procedure CheckCondition(Condition: Boolean; EClass: ExceptClass; const EMessage: string);
begin
  if not Condition then raise EClass.Create(EMessage);
end;

procedure InformationMessage(const Msg: string);
begin
  if Assigned(InformationProc) then
    InformationProc(Msg) else raise EInformationMessage.Create(Msg);
end;

procedure WarningMessage(const Msg: string);
begin
  if Assigned(WarningProc) then
    WarningProc(Msg) else raise EWarningMessage.Create(Msg);
end;

function Max(A, B: Integer): Integer; assembler;
asm
        CMP     EAX,EDX
        JG      @@Exit
        MOV     EAX,EDX
@@Exit:
end;

function Min(A, B: Integer): Integer; assembler;
asm
        CMP     EAX,EDX
        JL      @@Exit
        MOV     EAX,EDX
@@Exit:
end;

function RangeCheck(Value, Min, Max: Integer): Integer;
begin
  if Value < Min then Result := Min
  else if Value > Max then Result := Max
  else Result := Value;
end;

function RoundFloat(Value: Extended; Digits: Integer): Extended;
var
  StrFmt: string;
begin
  StrFmt := '%.' + IntToStr(Digits) + 'f';
  Result := StrToFloat(Format(StrFmt, [Value]));
end;

function CompareInteger(Value1, Value2: Integer): Integer;
asm
      MOV       ECX,EAX
      XOR       EAX,EAX
      CMP       ECX,EDX
      JG        @@G
      JE        @@Q
@@G:  INC       EAX
      JMP       @@Q
@@L:  DEC       EAX
@@Q:
end;

function CompareDWord(Value1, Value2: DWord): Integer;
asm
      MOV       ECX,EAX
      XOR       EAX,EAX
      CMP       ECX,EDX
      JA        @@G
      JE        @@Q
@@G:  INC       EAX
      JMP       @@Q
@@L:  DEC       EAX
@@Q:
end;

{$IFDEF _D4_}
function CompareInt64(const Value1, Value2: Int64): Integer;
asm
      MOV       ECX,DWORD PTR [Value1]
      MOV       EDX,DWORD PTR [Value1 + 4]
      XOR       EAX,EAX
@C1:  CMP       EDX,DWORD PTR [Value2]
      JG        @@G
      JL        @@L
@C2:  CMP       ECX,DWORD PTR [Value2 + 4]
      JB        @@L
      JE        @@Q
@@G:  INC       EAX
      JMP       @@Q
@@L:  DEC       EAX
@@Q:
end;

function CompareUInt64(const Value1, Value2: Int64): Integer;
asm
      MOV       ECX,DWORD PTR [Value1]
      MOV       EDX,DWORD PTR [Value1 + 4]
      XOR       EAX,EAX
@C1:  CMP       EDX,DWORD PTR [Value2]
      JA        @@G
      JB        @@L
@C2:  CMP       ECX,DWORD PTR [Value2 + 4]
      JB        @@L
      JE        @@Q
@@G:  INC       EAX
      JMP       @@Q
@@L:  DEC       EAX
@@Q:
end;
{$ENDIF}

function CompareFloat(Value1, Value2: Extended; Digits: Integer): Integer;
var
  Delta: Extended;
begin
  Value1 := Value1 - Value2;
  Delta := IntPower(1E1, - Digits);
  if Abs(Value1) <= Delta then Result := 0
  else if (Value1 > 0) then Result := 1
  else Result := -1;
end;

function IsEqualFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
begin
  Result := CompareFloat(Value1, Value2, Digits) = 0;
end;

function IsAboveFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
begin
  Result := CompareFloat(Value1, Value2, Digits) = 1;
end;

function IsBehindFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
begin
  Result := CompareFloat(Value1, Value2, Digits) = -1;
end;

function IsAboveEqualFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
begin
  Result := CompareFloat(Value1, Value2, Digits) >= 0;
end;

function IsBehindEqualFloat(Value1, Value2: Extended; Digits: Integer): Boolean;
begin
  Result := CompareFloat(Value1, Value2, Digits) <= 0;
end;

function StrToFloatDef(const Value: string; Default: Extended): Extended;
begin
  try
    Result := StrToFloat(Value);
  except
    on EConvertError do
      Result := Default
    else
      raise;
  end;
end;

function Bin2Hex(Bytes: PChar; Count: Integer): string;
var
  I: Integer;
begin
  Result := '';
  if Assigned(Bytes) then
  for I := 0 to Count - 1 do
    Result := Result + IntToHex(Byte((Bytes + I)^), 2);
end;

procedure Hex2Bin(Hex: string; Bytes: PChar; Count: Integer);
var
  I: Integer;
  C: Integer;
begin
  for I := 0 to Count - 1 do
  begin
    C := StrToInt('$' + Copy(Hex, 1 + I * 2, 2));
    (PChar(Bytes) + I)^ := Chr(C);
  end;
end;

function CompareMem(P1, P2: Pointer; Length: Integer): Boolean; assembler;
{$IFNDEF _D3_}
asm
        PUSH    ESI
        PUSH    EDI
        MOV     ESI,P1
        MOV     EDI,P2
        MOV     EDX,ECX
        XOR     EAX,EAX
        AND     EDX,3
        SHR     ECX,1
        SHR     ECX,1
        REPE    CMPSD
        JNE     @@2
        MOV     ECX,EDX
        REPE    CMPSB
        JNE     @@2
@@1:    INC     EAX
@@2:    POP     EDI
        POP     ESI
end;
{$ELSE}
asm
        JMP     SysUtils.CompareMem
end;
{$ENDIF}

function FindInteger(Value: Integer; const Buff; Count: Integer): Integer; assembler;
asm
        XCHG    EDI,EDX
        PUSH    ECX
        REPNE   SCASD
        MOV     EDI,EDX
        POP     EAX
        JE      @@1
        XOR     EAX,EAX
@@1:    SUB     EAX,ECX
        DEC     EAX
        MOV     EDI,EDX
end;

function CompareChars(const Buffer1, Buffer2; Count: Integer): Integer;
asm
        PUSH    ESI
        PUSH    EDI
        MOV     ESI, EAX
        MOV     EDI, EDX
        XOR     EAX, EAX
        REPE    CMPSB
        JB      @@1
        NEG     ECX
@@1:    SUB     EAX,ECX
        POP     EDI
        POP     ESI
end;

procedure ZeroMem(pBuff: Pointer; Count: Integer);
asm
        MOV     ECX,EDX
        SAR     ECX,2
        JS      @@exit
        PUSH    EDI
        MOV     EDI,EAX { Point EDI to destination      }
        XOR     EAX,EAX
        REP     STOSD   { Fill count DIV 4 dwords       }
        MOV     ECX,EDX
        AND     ECX,3
        REP     STOSB   { Fill count MOD 4 bytes        }
        POP     EDI
@@exit:
end;

{ 'Like' code is written by Wladimir Perepletchick }
{ Fido: 2:5037/10                                  }
function Like(const Source, Template: String): Boolean;
const
  SpecialChars: TCharSet = ['%', '*', '?', '_'];
var
 I, J, K, LTemplate, LSource: Integer;
begin
  Result := False;
  LTemplate := Length(Template);
  LSource := Length(Source);
  I := 1; J := 1;
  while (I <= LTemplate) and (J <= LSource) do
  begin
    case Template[I] of
      '?', '_':
        ;
      '*', '%':
        begin
          while (Template[I] in SpecialChars) and (I <= LTemplate) do Inc(I);
          if I > LTemplate then
            Result := True
          else
            while J <= LSource do
            begin
              while (Source[J] <> Template[I]) and (J <= LSource) do Inc(J);
              if J > LSource then Break;
              K := 0;
              while (Source[J + K] = Template[I + K]) and
                    (J + K <= LSource) and (I + K <= LTemplate) and
                    (not (Template[I + K] in SpecialChars)) do Inc(K);
              if (Template[I + K] in SpecialChars) or (I + K > LTemplate) then
              begin
                Inc(I, K - 1);
                Inc(J, K - 1);
                Break;
              end;
              Inc(J, K);
            end;
            if J > LSource then Break;
        end;
      else
        if (Source[J] <> Template[I]) then Break;
    end;
    Inc(I); Inc(J);
    if (J > LSource) then
    begin
      K := 0;
      while (Template[I + K] in ['%', '*']) and (I + K <= LTemplate) do Inc(K);
      if (I + K > LTemplate) then Result := True;
    end;
  end;
end;

procedure AddDelimeted(var S: string; const SubStr, Delimeter: string);
begin
  if S <> '' then S := S + Delimeter;
  S := S + SubStr;
end;

function GetListString(Fmt: string; Strings: TStrings): string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to Strings.Count - 1 do
    Result := Result + Format(Fmt, [Strings[I]]);
end;

function ExtractDelimeted(const S, Delimeter: string; var Pos: Integer): string;
var
  Tmp: string;
  I: Integer;
begin
  Tmp := Copy(S, Pos, MaxInt);
  I := System.Pos(Delimeter, Tmp) - 1;
  if I >= 0 then
  begin
    Result := Trim(Copy(S, Pos, I));
    Pos := I + Length(Delimeter) + Pos;
  end else begin
    Result := Trim(Tmp);
    Pos := Length(S) + 1;
  end;
end;

function ExtractDelimetedWord(const S, Delimeter: string; Number: Integer; var Pos: Integer): string;
var
  Tmp: string;
begin
  while (Number > 0) and (Pos <= Length(S)) do
  begin
    Tmp := ExtractDelimeted(S, Delimeter, Pos);
    Dec(Number);
  end;
  if Number = 0 then Result := Tmp else Result := '';
end;

procedure GetDelimetedStrings(const S, Delimeter: string; List: TStrings);
var
  Pos: Integer;
begin
  Pos := 1;
  List.BeginUpdate;
  try
    while (Pos <= Length(S)) do
      List.Add(ExtractDelimeted(S, Delimeter, Pos));
  finally
    List.EndUpdate;
  end;
end;

function PosText(const SubStr, Source: string): Integer;
begin
  Result := Pos(AnsiUpperCase(SubStr), AnsiUpperCase(Source));
end;

function ReplaceStr(const S, Srch, Replace: string): string;
var
  I: Integer;
  Source: string;
begin
  Source := S;
  Result := '';
  repeat
    I := Pos(Srch, Source);
    if I > 0 then
    begin
      Result := Result + Copy(Source, 1, I - 1) + Replace;
      Source := Copy(Source, I + Length(Srch), MaxInt);
    end else
      Result := Result + Source;
  until I <= 0;
end;

function WordCount(const S: string; const WordDelims: TCharSet): Integer;
var
  SLen, I: Cardinal;
begin
  Result := 0;
  I := 1;
  SLen := Length(S);
  while I <= SLen do
  begin
    while (I <= SLen) and (S[I] in WordDelims) do Inc(I);
    if I <= SLen then Inc(Result);
    while (I <= SLen) and not(S[I] in WordDelims) do Inc(I);
  end;
end;

function WordPosition(const N: Integer; const S: string;
  const WordDelims: TCharSet): Integer;
var
  Count, I: Integer;
begin
  Count := 0;
  I := 1;
  Result := 0;
  while (I <= Length(S)) and (Count <> N) do
  begin
    { skip over delimiters }
    while (I <= Length(S)) and (S[I] in WordDelims) do Inc(I);
    { if we're not beyond end of S, we're at the start of a word }
    if I <= Length(S) then Inc(Count);
    { if not finished, find the end of the current word }
    if Count <> N then
      while (I <= Length(S)) and not (S[I] in WordDelims) do Inc(I)
    else Result := I;
  end;
end;

function ExtractWord(N: Integer; const S: string;
  const WordDelims: TCharSet): string;
var
  I: Integer;
  Len: Integer;