delphi - 如何从 VCL.Graphics 获取所有已注册的文件格式...但 64 位

Question

在我的 32 位应用程序中，我使用 FindRegisteredPictureFileFormats unit provided by Cosmin Prund =>(How to get all of the supported file formats from Graphics unit?)。

我需要相同的但64位的。 David Heffernan 回答说已经有 64 位版本了。这段代码可以公开吗？

非常感谢!!

Answer 1

我相信这个单元可以满足您的需求。我已经在 32 位和 64 位 Windows 上测试了它，无论是否带有运行时包。我没有用自上而下的内存分配来测试它，但我不相信存在指针截断错误。

unit FindRegisteredPictureFileFormats;

{$POINTERMATH ON}

interface

uses Classes, Contnrs;

// Extracts the file extension + the description; Returns True if the hack was successful,
// False if unsuccesful.
function GetListOfRegisteredPictureFileFormats(List: TStrings): Boolean;

// This returns the list of TGraphicClass registered; True for successful hack, false
// for unsuccesful hach
function GetListOfRegisteredPictureTypes(List: TClassList): Boolean;

implementation

uses Graphics;

type
  TRelativeCallOpcode = packed record
    OpCode: Byte;
    Offset: Integer;
  end;

  PRelativeCallOpcode = ^TRelativeCallOpcode;

  TLongAbsoluteJumpOpcode = packed record
    OpCode: array [0 .. 1] of Byte;
    Destination: Cardinal;
  end;

  PLongAbsoluteJumpOpcode = ^TLongAbsoluteJumpOpcode;

  TReturnTList = function: TList;

  // Structure copied from Graphics unit.
  PFileFormat = ^TFileFormat;

  TFileFormat = record
    GraphicClass: TGraphicClass;
    Extension: string;
    Description: string;
    DescResID: Integer;
  end;

function FindFirstRelativeCallOpcode(StartOffset: NativeUInt): NativeUInt;
var
  Ram: ^Byte;
  i: Integer;
  PLongJump: PLongAbsoluteJumpOpcode;
begin
  Ram := nil;

  PLongJump := PLongAbsoluteJumpOpcode(@Ram[StartOffset]);
  if (PLongJump^.OpCode[0] = $FF) and (PLongJump^.OpCode[1] = $25) then
{$IF Defined(WIN32)}
    Result := FindFirstRelativeCallOpcode(PNativeUInt(PLongJump^.Destination)^)
{$ELSEIF Defined(Win64)}
    Result := FindFirstRelativeCallOpcode(PNativeUInt(PLongJump^.Destination + StartOffset + SizeOf(PLongJump^))^)
{$ELSE}
    {$MESSAGE Fatal 'Architecture not supported'}
{$ENDIF}
  else
  begin
    for i := 0 to 64 do
      if PRelativeCallOpcode(@Ram[StartOffset + i])^.OpCode = $E8 then
        Exit(StartOffset + i + PRelativeCallOpcode(@Ram[StartOffset + i])
          ^.Offset + 5);
    Result := 0;
  end;
end;

procedure FindGetFileFormatsFunc(out ProcAddr: TReturnTList);
var
  Offset_from_RegisterFileFormat: NativeUInt;
  Offset_from_RegisterFileFormatRes: NativeUInt;
begin
  Offset_from_RegisterFileFormat := FindFirstRelativeCallOpcode(NativeUInt(@TPicture.RegisterFileFormat));
  Offset_from_RegisterFileFormatRes := FindFirstRelativeCallOpcode(NativeUInt(@TPicture.RegisterFileFormatRes));

  if (Offset_from_RegisterFileFormat = Offset_from_RegisterFileFormatRes) then
    ProcAddr := TReturnTList(Pointer(Offset_from_RegisterFileFormat))
  else
    ProcAddr := nil;
end;

function GetListOfRegisteredPictureFileFormats(List: TStrings): Boolean;
var
  GetListProc: TReturnTList;
  L: TList;
  i: Integer;
begin
  FindGetFileFormatsFunc(GetListProc);
  if Assigned(GetListProc) then
  begin
    Result := True;
    L := GetListProc;
    for i := 0 to L.Count - 1 do
      List.Add(PFileFormat(L[i])^.Extension + '=' + PFileFormat(L[i])
        ^.Description);
  end
  else
    Result := False;
end;

function GetListOfRegisteredPictureTypes(List: TClassList): Boolean;
var
  GetListProc: TReturnTList;
  L: TList;
  i: Integer;
begin
  FindGetFileFormatsFunc(GetListProc);
  if Assigned(GetListProc) then
  begin
    Result := True;
    L := GetListProc;
    for i := 0 to L.Count - 1 do
      List.Add(PFileFormat(L[i])^.GraphicClass);
  end
  else
    Result := False;
end;

end.