Как получить все зарегистрированные форматы файлов из VCL.Graphics, но 64-битные

Я считаю, что этот блок делает то, что вы ищете. Я тестировал его на 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.