vgutils.pas

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

    Result := VarRecToVariant(Args[0])
  else begin
    Result := VarArrayCreate([0, High(Args)], varVariant);
    for I := 0 to High(Args) do
      Result[I] := VarRecToVariant(Args[I]);
  end;
end;

function VarArrayFromConstCast(const Args: array of const): Variant;
var
  I, Count: Integer;
begin
  Count := (High(Args) + 1) div 2;
  if Count <= 0 then
  begin
    Result := Null;
    Exit;
  end;
  if Count = 1 then
    Result := VarAsType(VarRecToVariant(Args[0]), Args[1].VInteger)
  else begin
    Result := VarArrayCreate([0, Count - 1], varVariant);
    for I := 0 to Count - 1 do
      Result[I] := VarAsType(VarRecToVariant(Args[I * 2]), Args[I * 2 + 1].VInteger)
  end;
end;

function VarArrayCast(const Values: Variant; Args: array of Integer): Variant;
var
  I, Count: Integer;
begin
  Result := Values;
  Count := (High(Args) - Low(Args) + 1) div 2;
  for I := 0 to Count - 1 do
    Result[Args[I * 2]] := VarAsType(Result[Args[I * 2]], Args[I * 2 + 1])
end;

function VarArrayOfPairs(const Args: array of const): Variant;
var
  Value: Variant;
  I, Count: Integer;
begin
  Count := (High(Args) - Low(Args) + 1) div 2;
  Result := VarArrayCreate([0, Count - 1], varVariant);
  for I := 0 to Count - 1 do
  begin
    Value := VarArrayCreate([0, 1], varVariant);
    Value[0] := VarRecToVariant(Args[I * 2]);
    Value[1] := VarRecToVariant(Args[I * 2 + 1]);
    Result[I] := Value;
  end;
end;

function VarArrayOfPairsCast(const Values: Variant; const Args: array of Integer): Variant;
var
  Value: Variant;
  I, Count: Integer;
begin
  Result := Values;
  Count := (High(Args) - Low(Args) + 1) div 2;
  for I := 0 to Count - 1 do
  begin
    Value := Result[Args[I * 2]];
    Value[1] := VarAsType(Value[1], Args[I * 2 + 1]);
    Result[Args[I * 2]] := Value;
  end;
end;

procedure StringsFromVarArray(const List: Variant; Strings: TStrings);
var
  I: Integer;
begin
  Strings.BeginUpdate;
  try
    Strings.Clear;
    if VarIsArray(List) and (VarArrayDimCount(List) = 1) then
      for I := VarArrayLowBound(List, 1) to VarArrayHighBound(List, 1) do
        Strings.Add(List[I]);
  finally
    Strings.EndUpdate;
  end;
end;

function VarArrayFromStrings(Strings: TStrings): Variant;
var
  I: Integer;
begin
  Result := Null;
  if Strings.Count > 0 then
  begin
    Result := VarArrayCreate([0, Strings.Count - 1], varOleStr);
    for I := 0 to Strings.Count - 1 do Result[I] := VarAsType(Strings[I], varOleStr);
  end;
end;

procedure EnumStrings(List: TStrings; EnumProc: TGetStrProc);
var
  I: Integer;
begin
  for I := 0 to List.Count - 1 do EnumProc(List[I]);
end;

procedure EnumVarArray(const List: Variant; EnumProc: TGetStrProc);
var
  S: TStrings;
begin
  S := TStringList.Create;
  try
    StringsFromVarArray(List, S);
    EnumStrings(S, EnumProc);
  finally
    S.Free;
  end;
end;

function VarToDispatch(Instance: Variant): IDispatch;
begin
  if TVarData(Instance).VType = varDispatch then
    Result := IDispatch(TVarData(Instance).VDispatch)
  else if TVarData(Instance).VType = (varDispatch or varByRef) then
    Result := IDispatch(TVarData(Instance).VPointer^)
  else
    Result := nil;
end;

procedure WriteBufferAt(Stream: TStream; const Buff; Count: Integer; Position: Integer);
var
  OldPos: Integer;
begin
  OldPos := Stream.Position;
  Stream.Position := Position;
  Stream.WriteBuffer(Buff, Count);
  Stream.Position := OldPos;
end;

procedure SwapStrings(var Str1, Str2: string);
var
  Tmp: string;
begin
  Tmp := Str1; Str1 := Str2; Str2 := Tmp;
end;

procedure SwapInteger(var Value1, Value2: Integer);
var
  Tmp: Integer;
begin
  Tmp := Value1;
  Value1 := Value2;
  Value2 := Tmp;
end;

function IsLeapYear(Year: Word): Boolean;
begin
  Result := (Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
end;

function GetDayTable(Year: Word): PDayTable;
const
  DayTable1: TDayTable = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  DayTable2: TDayTable = (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
  DayTables: array[Boolean] of PDayTable = (@DayTable1, @DayTable2);
begin
  Result := DayTables[IsLeapYear(Year)];
end;

procedure PreloadLibraries(const DLLs: array of PChar; Handles: PInstance);
var
  I: Integer;
  Handle: HINST;
begin
  for I := Low(DLLs) to High(DLLs) do
  begin
    Handle := LoadLibrary(DLLs[I]);
    Handles^ := Handle;
    Inc(LongInt(Handles), SizeOf(HINST));
  end;
end;

procedure UnloadLibraries(Handles: PInstance; Count: Integer);
var
  I: Integer;
  Handle: HINST;
begin
  for I := 0 to Count - 1 do
  begin
    Handle := Handles^;
    if Handle <> 0 then
      FreeLibrary(Handle);
    Inc(LongInt(Handles), SizeOf(HINST));
  end;
end;

function RegisterServer(const DLLName: string): Boolean;
var
  Handle: THandle;
  DllRegServ: procedure;
begin
  Result := False;
  try
    Handle := LoadLibrary(PChar(DLLName));
    if Handle >= HINSTANCE_ERROR then
    try
      DllRegServ := GetProcAddress(Handle, 'DllRegisterServer');
      if Assigned(DllRegServ) then
      begin
        DllRegServ;
        Result := True;
      end;
    finally
      FreeLibrary(Handle);
    end;
  except
    Result := False;
  end;
end;

{ Copied from RxLib }
{ SetVirtualMethodAddress procedure. Destroy destructor has index 0,
  first user defined virtual method has index 1. }

type
  PPointer = ^Pointer;

function GetVirtualMethodAddress(AClass: TClass; AIndex: Integer): Pointer;
var
  Table: PPointer;
begin
  Table := PPointer(AClass);
  Inc(Table, AIndex - 1);
  Result := Table^;
end;

function SetVirtualMethodAddress(AClass: TClass; AIndex: Integer;
  NewAddress: Pointer): Pointer;
const
  PageSize = SizeOf(Pointer);
var
  Table: PPointer;
  SaveFlag: DWORD;
begin
  Table := PPointer(AClass);
  Inc(Table, AIndex - 1);
  Result := Table^;
  if VirtualProtect(Table, PageSize, PAGE_EXECUTE_READWRITE, @SaveFlag) then
  try
    Table^ := NewAddress;
  finally
    VirtualProtect(Table, PageSize, SaveFlag, @SaveFlag);
  end;
end;

function FindVirtualMethodIndex(AClass: TClass; MethodAddr: Pointer): Integer;
begin
  Result := 0;
  repeat
    Inc(Result);
  until (GetVirtualMethodAddress(AClass, Result) = MethodAddr);
end;

{$IFDEF _D3_}
function ResStr(const Ident: string): string;
begin
  Result := Ident;
end;
{$ELSE}
function ResStr(Ident: Integer): string;
begin
  Result := LoadStr(Ident);
end;
{$ENDIF}

{$IFDEF _D3_}
type
  PStoredResStringData = ^TStoredResStringData;
  TStoredResStringData = record
    Addr: Pointer;
    Data: TResStringRec;
  end;

var
  StoredResStrings: TList = nil;

function FindStoredResStringData(P: PResStringRec): PStoredResStringData;
var
  I: Integer;
begin
  if Assigned(StoredResStrings) then
  begin
    for I := 0 to StoredResStrings.Count - 1 do
    begin
      Result := StoredResStrings[I];
      if Result^.Addr = P then Exit;
    end;
  end;
  Result := nil;
end;

procedure StoreResString(P: PResStringRec);
var
  Tmp: PStoredResStringData;
begin
  if not Assigned(FindStoredResStringData(P)) then
  begin
    GetMem(Tmp, SizeOf(TStoredResStringData));
    try
      Tmp^.Addr := P;
      Move(P^, Tmp^.Data, SizeOf(TResStringRec));
    except
      FreeMem(Tmp);
      raise;
    end;
    ListAdd(StoredResStrings, Tmp);
  end;
end;

procedure RestoreResString(P: PResStringRec);
var
  Tmp: PStoredResStringData;
begin
  Tmp := FindStoredResStringData(P);
  if Assigned(Tmp) then
  begin
    CopyResString(@Tmp^.Data, P, False);
    ListRemove(StoredResStrings, Tmp);
    FreeMem(Tmp);
  end;
end;

procedure FreeStoredResStrings;
var
  I: Integer;
  Tmp: PStoredResStringData;
begin
  if Assigned(StoredResStrings) then
  begin
    for I := StoredResStrings.Count - 1 downto 0 do
    begin
      Tmp := StoredResStrings[I];
      RestoreResString(Tmp^.Addr);
    end;
  end;
end;

procedure CopyResString(Source, Dest: PResStringRec; Store: Boolean);
var
  SaveFlag: Integer;
begin
  if VirtualProtect(Dest, SizeOf(TResStringRec), PAGE_READWRITE, @SaveFlag) then
  try
    if Store then StoreResString(Dest);
    Move(Source^, Dest^, SizeOf(TResStringRec));
  finally
    VirtualProtect(Dest, SizeOf(TResStringRec), SaveFlag, @SaveFlag);
  end;
end;
{$ENDIF}

function Win32Description: string;
var
  Ver: TOsVersionInfo;
  S: string;
begin
  Ver.dwOSVersionInfoSize := SizeOf(Ver);
  GetVersionEx(Ver);
  with Ver do
  begin
    case dwPlatformId of
      VER_PLATFORM_WIN32_WINDOWS:
        S := 'Windows';
      VER_PLATFORM_WIN32_NT:
        S := 'Windows NT'
    else
        S := 'Win32s';
    end;
    Result := Format('%s %d.%.2d (%s)', [S, dwMajorVersion, dwMinorVersion, szCSDVersion]);
  end;
end;

procedure GetEnvironment(Strings: TStrings);
var
  P: PChar;
  I: Integer;
begin
  P := GetEnvironmentStrings;
  try
    Strings.BeginUpdate;
    try
      Strings.Clear;
      while P^ <> #0 do
      begin
        I := Pos('=', P);
        Strings.Values[Copy(P, 1, I - 1)] := Copy(P, I + 1, 255);
        P := P + StrLen(P) + 1;
      end;
    finally
      Strings.EndUpdate;
    end;
  finally
    FreeEnvironmentStrings(P);
  end;
end;

function GetEnvironmentVariable(const Variable: string): string;
var
  Buff: array[0..1023] of Char;
begin
  Buff[0] := #0;
  Windows.GetEnvironmentVariable(PChar(Variable), Buff, SizeOf(Buff));
  Result := StrPas(Buff);
end;

function IsMainThread: Boolean;
begin
 Result := GetCurrentThreadID = MainThreadID;
end;

function GetProcessHandle(ProcessID: DWORD): THandle;
begin
  Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
end;

function GetPropType(PropInfo: PPropInfo): PTypeInfo;
begin
{$IFDEF _D3_}
  Result := PropInfo^.PropType^;
{$ELSE}
  Result := PropInfo^.PropType;
{$ENDIF}
end;

procedure GetPropInfoList(List: TList; Instance: TObject; Filter: TTypeKinds);
var
  Count: Integer;
begin
  List.Clear;
  try
    Count := GetPropList(Instance.ClassInfo, Filter, nil);
    List.Count := Count;
    GetPropList(Instance.ClassInfo, Filter, PPropList(List.List));
  except
    List.Clear;
    raise;
  end;
end;

initialization
  InitializeCriticalSection(FLogLock);
  AppFileName := ParamStr(0);

finalization
  DeleteCriticalSection(FLogLock);
{$IFDEF _D3_}
  FreeStoredResStrings;
{$ENDIF}

end.