rm_jvvcl5utils.pas

这是一个功能强大

        Result := Relocation.Address^;
end;

function AllocateHWnd(Method: TWndMethod): HWND;
begin
  Result := Forms.AllocateHWnd(Method);
end;

procedure DeallocateHWnd(Wnd: HWND);
begin
  Forms.DeallocateHWnd(Wnd);
end;

type
  TModRM = record
    Mode: Byte;
    RegOp: Byte;
    RM: Byte;
  end;

function GetModRM(B: Byte): TModRM;
begin
  Result.Mode := B shr 6;
  Result.RegOp := (B shr 3) and $07;
  Result.RM := B and $07;
end;

function GetDisassembledByteCount(const Bytes: array of Byte): Integer;
var
  I, LastByteCount: Integer;
  ModRM: TModRM;
begin
  Result := 0;
  LastByteCount := 0;
  I := 0;
  while I < Length(Bytes) do
  begin
    LastByteCount := Result;
    case Bytes[I] of
      $53..$56:
        ; // push reg
      $8B, $3B: // mov/cmp
        begin
          Inc(I);
          ModRM := GetModRM(Bytes[I]);
          case ModRM.Mode of
            $00:
              if ModRM.RM = $07 then
                Inc(I, 2); // mov reg, disp16
            $01:
              Inc(I); // mov reg, [reg]+disp8
            $02:
              Inc(I, 2); // mov reg, [reg]+disp16
          end;
        end;
      $E8:
        Inc(I, 4); // call rel32
      $5B..$5E:
        ; // pop reg
      $C3:
        ; // ret
      $E9:
        Inc(I, 4); // jmp rel32
      $83: // add
        Inc(I, 2);
      $89:
        Inc(I, 2);
    end;                                         
    Inc(I);
    Result := I;
  end;
  if I > Length(Bytes) then
    Result := LastByteCount;
end;

function InstallProcHook(ProcAddress, HookProc, OrgCallProc: Pointer): Boolean;
var
  Code: TJumpCode;
  OrgCallCode: TOrgCallCode;
  I, Count: Integer;
begin
  ProcAddress := GetRelocAddress(ProcAddress);
  Result := False;
  if Assigned(ProcAddress) and Assigned(HookProc) then
  begin
    if OrgCallProc <> nil then
    begin
      if ReadProtectedMemory(ProcAddress, OrgCallCode, SizeOf(OrgCallCode.Code)) then
      begin
        Count := GetDisassembledByteCount(OrgCallCode.Code);
        for I := Count to SizeOf(OrgCallCode.Code) do
          OrgCallCode.Code[I] := $90; // NOP
        OrgCallCode.Jmp := $E9;
        OrgCallCode.Offset := (Integer(ProcAddress) {+ SizeOf(Code)}+ Count) -
          Integer(OrgCallProc) -
          (SizeOf(OrgCallCode) - SizeOf(OrgCallCode.Address));
        OrgCallCode.Address := ProcAddress;

        WriteProtectedMemory(OrgCallProc, OrgCallCode, SizeOf(OrgCallCode));
        FlushInstructionCache(GetCurrentProcess, OrgCallProc, SizeOf(OrgCallCode));
      end;
    end;

    Code.Jmp := $E9;
    Code.Offset := Integer(HookProc) - (Integer(ProcAddress)) - SizeOf(Code);

    { The strange thing is that something overwrites the $e9 with a "PUSH xxx" }
    if WriteProtectedMemory(Pointer(Cardinal(ProcAddress)), Code, SizeOf(Code)) then
    begin
      FlushInstructionCache(GetCurrentProcess, ProcAddress, SizeOf(Code));
      Result := True;
    end;
  end;
end;

function UninstallProcHook(OrgCallProc: Pointer): Boolean;
var
  OrgCallCode: TOrgCallCode;
  ProcAddress: Pointer;
begin
  Result := False;
  if Assigned(OrgCallProc) then
    if OrgCallProc <> nil then
      if ReadProtectedMemory(OrgCallProc, OrgCallCode, SizeOf(OrgCallCode)) then
      begin
        ProcAddress := OrgCallCode.Address;

        Result := WriteProtectedMemory(ProcAddress, OrgCallCode, SizeOf(TJumpCode));
        FlushInstructionCache(GetCurrentProcess, ProcAddress, SizeOf(OrgCallCode));
      end;
end;


// SysUtils
function TryStrToInt(const S: string; out Value: Integer): Boolean;
var
  E: Integer;
begin
  Val(S, Value, E);
  Result := E = 0;
end;

function TryStrToDateTime(const S: string; out Date: TDateTime): Boolean;
begin
  Result := True;
  try
    Date := StrToDateTime(S);
  except
    Result := False;
  end;
end;

{ TODO -oJVCL -cTODO : Implement these better for D5! }

function StrToDateTimeDef(const S: string; Default: TDateTime): TDateTime;
begin
  // stupid and slow but at least simple
  try
    Result := StrToDateTime(S);
  except
    Result := Default;
  end;
end;

function StrToDateDef(const S: string; Default: TDateTime): TDateTime;
begin
  // stupid and slow but at least simple
  try
    Result := StrToDate(S);
  except
    Result := Default;
  end;
end;

const
  OneMillisecond = 1 / 24 / 60 / 60 / 1000; // as TDateTime

function CompareDateTime(const A, B: TDateTime): Integer;
begin
  if Abs(A - B) < OneMillisecond then
    Result := 0
  else
  if A < B then
    Result := -1
  else
    Result := 1;
end;

procedure RaiseLastOSError;
begin
  RaiseLastWin32Error;
end;

function IncludeTrailingPathDelimiter(const APath: string): string;
begin
  if (APath <> '') and (APath[Length(APath)] <> PathDelim) then
    Result := APath + PathDelim
  else
    Result := APath;
end;

function ExcludeTrailingPathDelimiter(const APath: string): string;
var
  I: Integer;
begin
  Result := APath;
  I := Length(Result);
  while (I > 0) and (Result[I] = PathDelim) do
    Dec(I);
  SetLength(Result, I);
end;

function DirectoryExists(const Name: string): Boolean;
var
  Code: Cardinal;
begin
  Code := Integer(GetFileAttributes(PChar(Name)));
  Result := (Code <> $FFFFFFFF) and (Code and FILE_ATTRIBUTE_DIRECTORY <> 0);
end;

function ForceDirectories(Dir: string): Boolean;
begin
  Result := True;
  if Dir[Length(Dir)] = PathDelim then
    Delete(Dir, Length(Dir), 1);
  if (Length(Dir) < 3) or DirectoryExists(Dir) or (ExtractFilePath(Dir) = Dir) then
    Exit; { avoid 'xyz:\' problem }
  Result := ForceDirectories(ExtractFilePath(Dir));
  if Result then
    Result := CreateDir(Dir);
end;

function SameFileName(const FN1, FN2: string): Boolean;
begin
  Result := CompareText(FN1, FN2) = 0;
end;

function GetEnvironmentVariable(const Name: string): string;
var
  Len: Integer;
begin
  SetLength(Result, 4 * 1024);
  Len := Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Length(Result));
  if Len <= Length(Result) then
    SetLength(Result, Len)
  else
  begin
    SetLength(Result, Len - 1);
    Windows.GetEnvironmentVariable(PChar(Name), PChar(Result), Len);
  end;
end;

function Supports(Instance: TObject; const Intf: TGUID): Boolean;
begin
  Result := (Instance <> nil) and (Instance.GetInterfaceEntry(Intf) <> nil);
end;

function Supports(AClass: TClass; const Intf: TGUID): Boolean;
begin
  Result := (AClass <> nil) and (AClass.GetInterfaceEntry(Intf) <> nil);
end;

function FileIsReadOnly(const FileName: string): Boolean;
var
  Attr: Cardinal;
begin
  Attr := GetFileAttributes(PChar(FileName));
  Result := (Attr <> $FFFFFFFF) and (Attr and FILE_ATTRIBUTE_READONLY <> 0);
end;

function WideCompareText(const S1, S2: WideString): Integer;
begin
  if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
    Result := CompareText(string(S1), string(S2))
  else
    Result := CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
      PWideChar(S1), Length(S1), PWideChar(S2), Length(S2)) - 2;
end;

function WideUpperCase(const S: WideString): WideString;
begin
  Result := S;
  if Result <> '' then
    CharUpperBuffW(Pointer(Result), Length(Result));
end;

function WideLowerCase(const S: WideString): WideString;
begin
  Result := S;
  if Result <> '' then
    CharLowerBuffW(Pointer(Result), Length(Result));
end;


// StrUtils
function AnsiStartsText(const SubText, Text: string): Boolean;
var
  SubTextLen: Integer;
begin
  SubTextLen := Length(SubText);
  if SubTextLen > Length(Text) then
    Result := False
  else
    Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE,
      PChar(Text), SubTextLen, PChar(SubText), SubTextLen) = 2;
end;

function AnsiEndsText(const SubText, Text: string): Boolean;
var
  SubTextStart: Integer;
begin
  SubTextStart := Length(Text) - Length(SubText) + 1;
  if (SubTextStart > 0) and (SubText <> '') and (ByteType(Text, SubTextStart) <> mbTrailByte) then
    Result := AnsiStrIComp(Pointer(SubText), PChar(Pointer(Text)) + SubTextStart - 1) = 0
  else
    Result := False;
end;

function AnsiStartsStr(const SubStr, Str: string): Boolean;
var
  SubStrLen: Integer;
begin
  SubStrLen := Length(SubStr);
  if SubStrLen > Length(Str) then
    Result := False
  else
    Result := CompareString(LOCALE_USER_DEFAULT, 0,
      PChar(Str), SubStrLen, PChar(SubStr), SubStrLen) = 2;
end;

function AnsiEndsStr(const SubStr, Str: string): Boolean;
var
  SubStrStart: Integer;
begin
  SubStrStart := Length(Str) - Length(SubStr) + 1;
  if (SubStrStart > 0) and (SubStr <> '') and (ByteType(Str, SubStrStart) <> mbTrailByte) then
    Result := AnsiStrComp(Pointer(SubStr), PChar(Pointer(Str)) + SubStrStart - 1) = 0
  else
    Result := False;
end;


// Math
function Sign(const AValue: Integer): TValueSign;
begin
  if AValue < 0 then
    Result := NegativeValue
  else
  if AValue > 0 then
    Result := PositiveValue
  else
    Result := ZeroValue;
end;

function Sign(const AValue: Int64): TValueSign;
begin
  if AValue < 0 then
    Result := NegativeValue
  else
  if AValue > 0 then
    Result := PositiveValue
  else
    Result := ZeroValue;
end;

function Sign(const AValue: Double): TValueSign;
begin
  if (PInt64(@AValue)^ and $7FFFFFFFFFFFFFFF) = $0000000000000000 then
    Result := ZeroValue
  else
  if (PInt64(@AValue)^ and $8000000000000000) = $8000000000000000 then
    Result := NegativeValue
  else
    Result := PositiveValue;
end;

// Variants
function VarIsStr(const V: Variant): Boolean;
var
  VarType: TVarType;
  VarData: PVarData;
begin
  VarData := @TVarData(V);
  while VarData.VType = varByRef or varVariant do
    VarData := PVarData(VarData.VPointer);

  VarType := VarData^.VType;
  Result := (VarType = varOleStr) or (VarType = varString);
end;

function FindVarData(const V: Variant): PVarData;
begin
  Result := @TVarData(V);
  while Result.VType = varByRef or varVariant do
    Result := PVarData(Result.VPointer);
end;

function VarIsType(const V: Variant; AVarType: TVarType): Boolean;
begin
  Result := FindVarData(V)^.VType = AVarType;
end;

function GetMonitorWorkareaRect(Monitor: TMonitor): TRect;
var
  MonInfo: TMonitorInfo;
begin
  MonInfo.cbSize := SizeOf(MonInfo);
  GetMonitorInfo(Monitor.Handle, @MonInfo);
  Result := MonInfo.rcWork;
end;

function VarCompareValue(const A, B: Variant): TVariantRelationship;
const
  CTruth: array [Boolean] of TVariantRelationship = (vrNotEqual, vrEqual);
var
  LA, LB: TVarData;
begin
  LA := FindVarData(A)^;
  LB := FindVarData(B)^;
  if LA.VType = varEmpty then
    Result := CTruth[LB.VType = varEmpty]
  else
  if LA.VType = varNull then
    Result := CTruth[LB.VType = varNull]
  else
  if LB.VType in [varEmpty, varNull] then
    Result := vrNotEqual
  else
  if A = B then
    Result := vrEqual
  else
  if A < B then
    Result := vrLessThan
  else
    Result := vrGreaterThan;
end;


//=== { TCustomImageList } ===================================================

{procedure TCustomImageList.Draw(Canvas: TCanvas; X, Y, Index: Integer;
  ADrawingStyle: TDrawingStyle; AImageType: TImageType; Enabled: Boolean);
const
  DrawingStyles: array[TDrawingStyle] of Longint =
  (ILD_FOCUS, ILD_SELECTED, ILD_NORMAL, ILD_TRANSPARENT);
  Images: array[TImageType] of Longint =
  (0, ILD_MASK);
begin
  if HandleAllocated then
    DoDraw(Index, Canvas, X, Y, DrawingStyles[ADrawingStyle] or
      Images[AImageType], Enabled);
end;}

function IncYear(const AValue: TDateTime;
  const ANumberOfYears: Integer): TDateTime;
begin
  Result := IncMonth(AValue, ANumberOfYears * 12);
end;

function FtpGetFileSize(hFile: HINTERNET; lpdwFileSizeHigh: LPDWORD): DWORD; stdcall;
  external 'wininet.dll' name 'FtpGetFileSize';

initialization

finalization
  if GlobalCollectionHooked then
    UnhookCollection;

{$ENDIF COMPILER5}

end.