Извлечение метаданных из MS Office документов

unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ComCtrls, Vcl.StdCtrls;
 
type
  TForm1 = class(TForm)
    btnGo: TButton;
    LV: TListView;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
uses ActiveX, ComObj;
 
{$R *.dfm}
function StgOpenStorageEx(const pwcsName: POleStr; grfMode: LongInt;
  stgfmt: DWORD; grfAttrs: DWORD; pStgOptions: Pointer; reserved2: Pointer;
  riid: PGUID; out stgOpen: IStorage): HResult; stdcall; external 'ole32.dll';
 
const
  // GUID для набора св-в SummaryInformation
  FMTID_SummaryInformation: TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
  IID_IPropertySetStorage: TGUID = '{0000013A-0000-0000-C000-000000000046}';
 
  STGFMT_FILE = 3;
  STGFMT_ANY = 4;
 
type
  PPropSpecArray = ^TPropSpecArray; // массив спецификаций свойств
  TPropSpecArray = array [0 .. 999] of TPropSpec;
 
  PPropVariantArray = ^TPropVariantArray;
  // массив - приемник, куда будут помещены значения нужных свойств
  TPropVariantArray = array [0 .. 999] of TPropVariant;
 
function IsNTFS(AFileName: string): boolean;
var
  fso, drv: OleVariant;
begin
  fso := CreateOleObject('Scripting.FileSystemObject');
  drv := fso.GetDrive(fso.GetDriveName(AFileName));
  Result := drv.FileSystem = 'NTFS'
end;
 
procedure TForm1.btnGoClick(Sender: TObject);
var
  fn: string;
  stgRoot: IStorage;
  stgPS: IPropertySetStorage;
  stgP: IPropertyStorage;
  ps: PPropSpecArray;
  pv: PPropVariantArray;
 
  LVI: TListItem;
begin
  fn := 'D:\test\01.doc';
 
  // Проверяем: если это не compound file и система - не NTFS, тогда выходим.
  // (для compound файлов FS не важна)
  if (StgIsStorageFile(StringToOleStr(fn)) <> S_OK) then
    if (not IsNTFS(fn)) then
    begin
      MessageBox(Handle, 'NTFS needed for non-compound files', 'Error',
        MB_ICONERROR);
      exit;
    end;
 
 
 
  if (StgOpenStorageEx(StringToOleStr(fn), STGM_READ or STGM_SHARE_DENY_WRITE,
    STGFMT_ANY, 0, nil, nil, @IID_IPropertySetStorage, stgRoot) <> S_OK) then
  // открываем его
  begin
    MessageBox(Handle, 'Невозможно открыть файл', 'Error', MB_ICONERROR);
    exit;
  end;
 
  stgPS := stgRoot as IPropertySetStorage; // ссылаемся на нужный интерфейс
  // открываем набор свойств
  if (stgPS.Open(FMTID_SummaryInformation, STGM_READ or STGM_SHARE_EXCLUSIVE, stgP) <> S_OK) then
  begin
    MessageBox(Handle, 'Невозможно открыть набор свойств', 'Error', MB_ICONERROR);
    exit;
  end;
 
  ps := nil;
  pv := nil;
  try
    GetMem(ps, SizeOf(TPropSpec));
    GetMem(pv, SizeOf(TPropVariant));
 
    ps[0].ulKind := PRSPEC_PROPID;
 
    ps[0].propid := PIDSI_TITLE; // заголовок
    LVI := LV.Items.Add;
    LVI.Caption := 'Title';
    if (stgP.ReadMultiple(1, @ps[0], @pv[0]) = S_OK) then
      LVI.SubItems.Add(pv[0].pszVal)
    else
      // Свойство не прочиталось
      LVI.SubItems.Add('');
 
  finally
    if assigned(ps) then
      FreeMem(ps);
    if assigned(pv) then
      FreeMem(pv);
 
    stgP := nil;
    stgPS := nil;
    stgRoot := nil;
  end;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  LV.Clear;
end;
 
end.