vgutils.pas

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

  MOV     DL,1
  CALL    dword ptr [ECX - 4] { vtDestroy }
  POP     EAX
  XOR     ECX, ECX
  MOV     [EAX], ECX
@@exit:
end;

procedure CopyMethodProps(Src, Dst: TObject);
var
  I, Count: Integer;
  PropList: PPropList;
  PropInfo: PPropInfo;
  Method: TMethod;
begin
  if not Dst.InheritsFrom(Src.ClassType) then Exit;
  PropList := nil;
  Count := GetTypeData(Src.ClassInfo)^.PropCount;
  try
    ReAllocMem(PropList, Count * SizeOf(Pointer));
    GetPropInfos(Src.ClassInfo, PropList);
    for I := 0 to Count - 1 do
    begin
      PropInfo := PropList^[I];
      if PropInfo^.PropType^.Kind = tkMethod then
      begin
        Method := GetMethodProp(Src, PropInfo);
        SetMethodProp(Dst, PropInfo, Method);
      end;
    end;
  finally
    ReAllocMem(PropList, 0);
  end;
end;

function UniqueName(Instance: TComponent; const Name: string; Owner: TComponent): string;
var
  I: Integer;
  Tmp: TComponent;
begin
  I := 0;
  Result := Name;
  if Assigned(Owner) then
  begin
    Tmp := Owner.FindComponent(Result);
    if Assigned(Tmp) and (Tmp <> Instance) then
    while (Tmp <> nil) do
    begin
      Result := Format('%s_%d', [Name, I]);
      Inc(I);
      Tmp := Owner.FindComponent(Result);
    end;
  end else begin
    Result := '';
    if Assigned(FindGlobalComponent) then
    begin
      Result := Name;
      while FindGlobalComponent(Result) <> nil do
      begin
        Result := Format('%s_%d', [Name, I]);
        Inc(I);
      end;
    end;
  end;
end;

procedure WriteAndRead(Src: TComponent; Dst: TComponent);
begin
  CopyProps(Src, Dst);
end;

procedure ForComponents(AComponents: array of TComponent;
  Callback: TComponentCallback; Data: Pointer);
var
  I: Integer;
begin
  for I := Low(AComponents) to High(AComponents) do
    Callback(AComponents[I], Data);
end;

procedure ForEachComponent(Instance: TComponent;
  ComponentClass: TComponentClass; Callback: TComponentCallback; Data: Pointer; Children: Boolean);
var
  I: Integer;
  C: TComponent;
begin
  for I := 0 to Instance.ComponentCount - 1 do
  begin
    C := Instance.Components[I];
    if C is ComponentClass then Callback(C, Data);
    if Children then ForEachComponent(C, ComponentClass, Callback, Data, Children);
  end;
end;

function AppPathFileName(FileName: TFileName): TFileName;
begin
  if ExtractFilePath(FileName) = '' then
    Result := ExtractFilePath(AppFileName) + FileName else
    Result := FileName;
end;

procedure WriteBoolean(const IniFile, IniSection, Ident: string; const Value: Boolean; UseRegistry: Boolean);
begin
  WriteInteger(IniFile, IniSection, Ident, Integer(Value), UseRegistry);
end;

procedure WriteFloat(const IniFile, IniSection, Ident: string; const Value: Double; UseRegistry: Boolean);
begin
  WriteString(IniFile, IniSection, Ident, FloatToStr(Value), UseRegistry);
end;

procedure WriteInteger(const IniFile, IniSection, Ident: string; const Value: Integer; UseRegistry: Boolean);
begin
  WriteString(IniFile, IniSection, Ident, IntToStr(Value), UseRegistry);
end;

procedure WriteString(const IniFile, IniSection, Ident, Value: string; UseRegistry: Boolean);
  function WriteIni: TObject;
  begin
    Result := TIniFile.Create(AppPathFileName(IniFile) + IniFileExt);
    with TIniFile(Result) do
      WriteString(IniSection, Ident, Value);
  end;

  function WriteReg: TObject;
  begin
    Result := TRegIniFile.Create(IniFile);
    with TRegIniFile(Result) do
      WriteString(IniSection, Ident, Value);
  end;
var
  Obj: TObject;
begin
  Obj := nil;
  try
    if UseRegistry then
      Obj := WriteReg else
      Obj := WriteIni;
  finally
    Obj.Free;
  end;
end;

function ReadBoolean(const IniFile, IniSection, Ident: string; const DefValue: Boolean; UseRegistry: Boolean): Boolean;
begin
  Result := Boolean(ReadInteger(IniFile, IniSection, Ident, Integer(DefValue), UseRegistry));
end;

function ReadFloat(const IniFile, IniSection, Ident: string; const DefValue: Double; UseRegistry: Boolean): Double;
var
  S: string;
begin
  S := ReadString(IniFile, IniSection, Ident, FloatToStr(DefValue), UseRegistry);
  try
    Result := StrToFloat(S);
  except
    Result := DefValue;
  end;
end;

function ReadInteger(const IniFile, IniSection, Ident: string; const DefValue: Integer; UseRegistry: Boolean): Integer;
begin
  try
    Result := StrToInt(ReadString(IniFile, IniSection, Ident, IntToStr(DefValue), UseRegistry));
  except
    Result := DefValue;
  end;
end;

function ReadString(const IniFile, IniSection, Ident, DefValue: string; UseRegistry: Boolean): string;
var
  S: string;
  function ReadIni: TObject;
  begin
    Result := TIniFile.Create(AppPathFileName(IniFile) + IniFileExt);
    with TIniFile(Result) do
      S := ReadString(IniSection, Ident, DefValue);
  end;

  function ReadReg: TObject;
  begin
    Result := TRegIniFile.Create(IniFile);
    with TRegIniFile(Result) do
      S := ReadString(IniSection, Ident, DefValue);
  end;
var
  Obj: TObject;
begin
  Obj := nil;
  try
    if UseRegistry then
      Obj := ReadReg else
      Obj := ReadIni;
    Result := S;
  finally
    Obj.Free;
  end;
end;

procedure AppWriteLog(const Msg: string);
begin
  WriteLog(Copy(AppFileName, 1, Length(AppFileName) - 3) + 'log', Msg);
end;

procedure WriteLog(const FileName: TFileName; const Msg: string);
var
  Tmp: string;
begin
  Tmp := DateTimeToStr(Now) + ' ' + Msg;
  EnterCriticalSection(FLogLock);
  try
    if Assigned(WriteLogProc) then
      WriteLogProc(FileName, Tmp)
    else
      DefaultWriteLog(FileName, Tmp);
  finally
    LeaveCriticalSection(FLogLock);
  end
end;

procedure DefaultWriteLog(const FileName: TFileName; const Msg: string);
begin
  try
    with TWinFileStream.Create(FileName, [famWrite], [fsmRead], fcmOpenAlways,
      FILE_ATTRIBUTE_NORMAL or FILE_FLAG_WRITE_THROUGH, nil, 0) do
    try
      Position := Size;
      WriteBuffer(PChar(Msg + #13#10)^, Length(Msg) + 2);
    finally
      Free;
    end;
  except end;
end;

function GetTempFileName(const Path: TFileName): TFileName;
var
  TmpFileName: TMaxPath;
begin
  Windows.GetTempFileName(PChar(Path), PChar('tmp'), 0, TmpFileName);
  Result := StrPas(TmpFileName);
end;

function BackupFile(const FileName: TFileName): Boolean;
var
  BakFileName: string;
begin
  Result := True;
  if FileExists(FileName) then
  begin
    BakFileName := ChangeFileExt(FileName, '.bak');
    if FileExists(BakFileName) then
      Result := DeleteFile(BakFileName);
    if Result then
      Result := RenameFile(FileName, BakFileName);
  end;
end;

procedure CheckBackupFile(const FileName: TFileName);
var
  BakFileName: string;
begin
  if FileExists(FileName) then
  begin
    BakFileName := ChangeFileExt(FileName, '.bak');
    if FileExists(BakFileName) then
      CheckDeleteFile(BakFileName);
    CheckRenameFile(FileName, BakFileName);
  end;
end;

procedure CheckDeleteFile(const FileName: TFileName);
begin
  CheckCondition(DeleteFile(FileName), EFileOperation, FmtLoadStr(SCannotDeleteFile, [FileName]));
end;

procedure CheckRenameFile(const OldName, NewName: TFileName);
begin
  CheckCondition(RenameFile(OldName, NewName), EFileOperation, FmtLoadStr(SCannotRenameFile, [OldName, NewName]));
end;

procedure LoadComponent(const FileName: string; Instance: TComponent);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    Stream.ReadComponent(Instance);
  finally
    Stream.Free;
  end;
end;

procedure SaveStream(const FileName: string; Source: TStream);
var
  TmpFileName: string;
  Stream: TStream;
begin
  TmpFileName := GetTempFileName(ExtractFilePath(AppFileName));
  try
    Stream := TFileStream.Create(TmpFileName, fmCreate);
    try
      Stream.CopyFrom(Source, Source.Size - Source.Position);
    finally
      Stream.Free;
    end;
    CheckBackupFile(FileName);
    CheckRenameFile(TmpFileName, FileName);
  except
    DeleteFile(TmpFileName);
    raise;
  end;
end;

procedure SaveComponent(const FileName: string; Instance: TComponent);
var
  Stream: TStream;
begin
  Stream := TMemoryStream.Create;
  try
    Stream.WriteComponent(Instance);
    Stream.Position := 0;
    SaveStream(FileName, Stream);
  finally
    Stream.Free;
  end;
end;

procedure GetFileNames(const Directory, FileMask: string; Attr: Integer; FileNames: TStrings);
var
  Status: Integer;
  SearchRec: TSearchRec;
  Mask: string;
begin
  with FileNames do
  begin
    BeginUpdate;
    try
      Clear;
      if Directory = '' then
        Mask := GetCurrentDir + '\' + FileMask else
        Mask := Directory + '\' + FileMask;

      Status := FindFirst(Mask, Attr, SearchRec);
      while Status = 0 do
      begin
        if (SearchRec.Attr and faDirectory) = 0 then
          Add(ExtractFilePath(Mask) + SearchRec.Name);
        Status := FindNext(SearchRec);
      end;
      FindClose(SearchRec);
    finally
      EndUpdate;
    end;
  end;
end;

function NvlInteger(const Value: Variant): Integer;
begin
  Result := 0;
  if not VarIsNull(Value) then
  try
    Result := VarAsType(Value, varInteger);
  except end;
end;

function NvlFloat(const Value: Variant): Double;
begin
  Result := 0;
  if not VarIsNull(Value) then
  try
    Result := VarAsType(Value, varDouble);
  except end;
end;

function NvlDateTime(const Value: Variant): TDateTime;
begin
  Result := 0;
  if not VarIsNull(Value) then
  try
    Result := VarAsType(Value, varDate);
  except end;
  if Result = 0 then Result := EncodeDate(1, 1, 1);
end;

function NvlString(const Value: Variant): string;
begin
  case TVarData(Value).VType of
    varOleStr, varString: Result := Value
  else
    Result := '';
  end;
end;

const
  VarTypesNumeric: array[0..5] of Integer = (varSmallInt, varInteger, varSingle, varDouble, varCurrency, varByte);
  VarTypesString:  array[0..1] of Integer = (varString, varOleStr);
  VarTypesNull:    array[0..0] of Integer = (varNull);
  VarTypesDate:    array[0..0] of Integer = (varDate);
  VarTypesBoolean: array[0..0] of Integer = (varBoolean);
  VarTypesEmpty:   array[0..0] of Integer = (varEmpty);

function VarComparable(const V1, V2: Variant): Boolean;
  function IsType(VarType: Integer; VarTypes: array of Integer): Boolean;
  var
    I: Integer;
  begin
    for I := Low(VarTypes) to High(VarTypes) do
    begin
      Result := VarType = VarTypes[I];
      if Result then Exit;
    end;
    Result := False;
  end;
var
  Type1, Type2: Integer;
  function IsBothType(VarTypes: array of Integer): Boolean;
  begin
    Result := IsType(Type1, VarTypes) and IsType(Type2, VarTypes);
  end;
begin
  Type1 := TVarData(V1).VType; Type2 := TVarData(V2).VType;
  Result := (
    IsBothType(VarTypesNumeric) or IsBothType(VarTypesString) or
    IsBothType(VarTypesNull) or IsBothType(VarTypesDate) or
    IsBothType(VarTypesBoolean) or IsBothType(VarTypesEmpty));
end;

function VarIsEqual(const V1, V2: Variant): Boolean;
begin
  Result := VarComparable(V1, V2) and (V1 = V2);
end;

function VarRecToVariant(VarRec: TVarRec): Variant;
begin
  with VarRec do case VType of
    vtInteger:    Result := VInteger;
    vtBoolean:    Result := VBoolean;
    vtChar:       Result := VChar;
    vtExtended:   Result := VExtended^;
    vtString:     Result := VString^;
    vtPChar:      Result := StrPas(VPChar);
    vtObject:     Result := VObject.ClassName;
    vtClass:      Result := VClass.ClassName;
    vtWideChar:   Result := VWideChar;
    vtPWideChar:  Result := VPWideChar^;
    vtAnsiString: Result := string(VAnsiString);
    vtCurrency:   Result := VCurrency^;
    vtVariant:    Result := VVariant^;
{$IFDEF _D3_}
    vtInterface:  Result := IUnknown(VInterface);
    vtWideString: Result := WideString(VWideString);
{$ENDIF}
  end;
end;

function VarArrayFromConst(const Args: array of const): Variant;
var
  I: Integer;
begin
  if High(Args) = 0 then