Как получить все поддерживаемые форматы файлов из графического блока?

Ответ 1

Вы работаете с элементом управления списком файлов и, предположительно, таким образом, списком имен файлов. Если вам не нужно знать фактические типы типов TGraphic, которые зарегистрированы, только если зарегистрировано заданное расширение файла (например, чтобы проверить, может ли более поздний вызов TPicture.LoadFromFile() с успехом преуспеть), вы можете используйте общедоступную функцию GraphicFileMask(), чтобы получить список зарегистрированных расширений файлов, а затем сравните свои имена файлов с этим списком. Например:

uses
  SysUtils, Classes, Graphics, Masks;

function IsGraphicClassRegistered(const FileName: String): Boolean;
var
  Ext: String;
  List: TStringList;
  I: Integer;
begin
  Result := False;
  Ext := ExtractFileExt(FileName);
  List := TStringList.Create;
  try
    List.Delimiter := ';';
    List.StrictDelimiter := True;
    List.DelimitedText := GraphicFileMask(TGraphic);
    for I := 0 to List.Count-1 do
    begin
      if MatchesMask(FileName, List[I]) then
      begin
        Result := True;
        Exit;
      end;
    end;
  finally
    List.Free;
  end;
end;

Или вы можете просто загрузить файл и посмотреть, что произойдет:

uses
  Graphics;

function GetRegisteredGraphicClass(const FileName: String): TGraphicClass;
var
  Picture: TPicture;
begin
  Result := nil;
  try
    Picture := TPicture.Create;
    try
      Picture.LoadFromFile(FileName);
      Result := TGraphicClass(Picture.Graphic.ClassType);
    finally
      Picture.Free;
    end;
  except
  end;
end;

Обновление:, если вы хотите извлечь расширения и описания, вы можете использовать TStringList.DelimitedText для анализа результата функции GraphicFilter():

uses
  SysUtils, Classes, Graphics;

function RPos(const ASub, AIn: String; AStart: Integer = -1): Integer;
var
  i: Integer;
  LStartPos: Integer;
  LTokenLen: Integer;
begin
  Result := 0;
  LTokenLen := Length(ASub);
  // Get starting position
  if AStart < 0 then begin
    AStart := Length(AIn);
  end;
  if AStart < (Length(AIn) - LTokenLen + 1) then begin
    LStartPos := AStart;
  end else begin
    LStartPos := (Length(AIn) - LTokenLen + 1);
  end;
  // Search for the string
  for i := LStartPos downto 1 do begin
    if Copy(AIn, i, LTokenLen) = ASub then begin
      Result := i;
      Break;
    end;
  end;
end;

procedure GetRegisteredGraphicFormats(AFormats: TStrings);
var
  List: TStringList;
  i, j: Integer;
  desc, ext: string;
begin
  List := TStringList.Create;
  try
    List.Delimiter := '|';
    List.StrictDelimiter := True;
    List.DelimitedText := GraphicFilter(TGraphic);
    i := 0;
    if List.Count > 2 then
      Inc(i, 2); // skip the "All" filter ...
    while i <= List.Count-1 do
    begin
      desc := List[i];
      ext := List[i+1];
      j := RPos('(', desc);
      if j > 0 then
        desc := TrimRight(Copy(desc, 1, j-1)); // remove extension mask from description
      AFormats.Add(ext + '=' + desc);
      Inc(i, 2);
    end;
  finally
    List.Free;
  end;
end;

Обновить 2:, если вас просто интересует список зарегистрированных расширений графических файлов, тогда, предполагая, что List является уже созданным потомком TStrings, используйте это:

ExtractStrings([';'], ['*', '.'], PChar(GraphicFileMask(TGraphic)), List);

Ответ 2

Проект GlScene имеет блок PictureRegisteredFormats.pas, который реализует для этого взлом.

Ответ 3

Здесь альтернативный взломан, который может быть безопаснее, затем GLScene. Это все еще хак, потому что желаемая структура является глобальной, но в разделе реализации блока Graphics.pas, но мой метод использует намного меньше "констант maigc" (жестко закодированные смещения в коде) и использует два разных метода для обнаружения функции GetFileFormats в Graphics.pas.

Мой код использует тот факт, что как TPicture.RegisterFileFormat, так и TPicture.RegisterFileFormatRes необходимо немедленно вызвать функцию Graphics.GetFileFormats. Код обнаруживает код операции относительного смещения CALL и регистрирует адрес назначения для обоих. Только продвигается вперед, если оба результата одинаковы, и это добавляет коэффициент безопасности. Другим фактором безопасности является сам метод обнаружения: даже если пролог, сгенерированный компилятором, изменится, если первая функция называется GetFileFormats, этот код находит это.

Я не собираюсь помещать "Warning: This will crash when Graphics.pas is compiled with the 'Use Debug DCUs' option." в верхнюю часть устройства (как показано в коде GLScene), потому что я тестировал как с debug dcu, так и без отладки dcu, и это сработало. Также тестировался с пакетами, и он все еще работал.

Этот код работает только для 32-битных целей, поэтому широкое использование Integer для операций указателя. Я попытаюсь сделать эту работу для 64-битных целей, как только я установлю свой компилятор Delphi XE2.

Обновление: Версия, поддерживающая 64 бит, можно найти здесь: fooobar.com/info/284037/...

unit FindReigsteredPictureFileFormats;

interface

uses Classes, Contnrs;

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

// This returns the list of TGraphicClass registered; True for successful hack, false
// for unsuccesful hach
function GetListOfRegisteredPictureTypes(const 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: PInteger;
  end;
  PLongAbsoluteJumpOpcode = ^TLongAbsoluteJumpOpcode;

  TMaxByteArray = array[0..System.MaxInt-1] of Byte;
  PMaxByteArray = ^TMaxByteArray;

  TReturnTList = function: TList;

  // Structure copied from Graphics unit.
  PFileFormat = ^TFileFormat;
  TFileFormat = record
    GraphicClass: TGraphicClass;
    Extension: string;
    Description: string;
    DescResID: Integer;
  end;

function FindFirstRelativeCallOpcode(const StartOffset:Integer): Integer;
var Ram: PMaxByteArray;
    i: Integer;
    PLongJump: PLongAbsoluteJumpOpcode;
begin
  Ram := nil;

  PLongJump := PLongAbsoluteJumpOpcode(@Ram[StartOffset]);
  if (PLongJump^.OpCode[0] = $FF) and (PLongJump^.OpCode[1] = $25) then
    Result := FindFirstRelativeCallOpcode(PLongJump^.Destination^)
  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: Integer;
    Offset_from_RegisterFileFormatRes: Integer;
begin
  Offset_from_RegisterFileFormat := FindFirstRelativeCallOpcode(Integer(@TPicture.RegisterFileFormat));
  Offset_from_RegisterFileFormatRes := FindFirstRelativeCallOpcode(Integer(@TPicture.RegisterFileFormatRes));

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

function GetListOfRegisteredPictureFileFormats(const 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(const 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.