Cara mendapatkan semua format file yang terdaftar dari VCL.Graphics tetapi 64bit

Saya yakin unit ini melakukan apa yang Anda cari. Saya sudah mengujinya pada Windows 32 bit dan 64 bit, dengan paket runtime dan tanpa. Saya belum mengujinya dengan alokasi memori top-down, tapi saya tidak yakin ada bug pemotongan pointer.

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.