Udtræk af hhv. meta Title, description, keywords i delphi

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,shellapi,
  StdCtrls;

type
  TFileVersionInfo = record
    FileType,
    CompanyName,
    FileDescription,
    FileVersion,
    InternalName,
    LegalCopyRight,
    LegalTradeMarks,
    OriginalFileName,
    ProductName,
    ProductVersion,
    Comments,
    SpecialBuildStr,
    PrivateBuildStr,
    FileFunction : string;
    DebugBuild,
    PreRelease,
    SpecialBuild,
    PrivateBuild,
    Patched,
    InfoInferred : Boolean;
    end;
  TForm1 = class(TForm)
    Button1: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}
function FileVersionInfo(const sAppNamePath: TFileName): TFileVersionInfo;
var
  rSHFI: TSHFileInfo;
  iRet: Integer;
  VerSize: Integer;
  VerBuf: PChar;
  VerBufValue: Pointer;
  VerHandle: Cardinal;
  VerBufLen: Cardinal;
  VerKey: string;
  FixedFileInfo: PVSFixedFileInfo;

  // dwFileType, dwFileSubtype
  function GetFileSubType(FixedFileInfo: PVSFixedFileInfo) : string;
  begin
    case FixedFileInfo.dwFileType of

      VFT_UNKNOWN: Result := 'Unknown';
      VFT_APP: Result := 'Application';
      VFT_DLL: Result := 'DLL';
      VFT_STATIC_LIB: Result := 'Static-link Library';

      VFT_DRV:
        case
          FixedFileInfo.dwFileSubtype of
          VFT2_UNKNOWN: Result := 'Unknown Driver';
          VFT2_DRV_COMM: Result := 'Communications Driver';
          VFT2_DRV_PRINTER: Result := 'Printer Driver';
          VFT2_DRV_KEYBOARD: Result := 'Keyboard Driver';
          VFT2_DRV_LANGUAGE: Result := 'Language Driver';
          VFT2_DRV_DISPLAY: Result := 'Display Driver';
          VFT2_DRV_MOUSE: Result := 'Mouse Driver';
          VFT2_DRV_NETWORK: Result := 'Network Driver';
          VFT2_DRV_SYSTEM: Result := 'System Driver';
          VFT2_DRV_INSTALLABLE: Result := 'InstallableDriver';
          VFT2_DRV_SOUND: Result := 'Sound Driver';
        end;
      VFT_FONT:
        case FixedFileInfo.dwFileSubtype of
          VFT2_UNKNOWN: Result := 'Unknown Font';
          VFT2_FONT_RASTER: Result := 'Raster Font';
          VFT2_FONT_VECTOR: Result := 'Vector Font';
          VFT2_FONT_TRUETYPE: Result :='Truetype Font';
          else;
        end;
      VFT_VXD: Result :='Virtual Defice Identifier = ' +
          IntToHex(FixedFileInfo.dwFileSubtype, 8);
    end;
  end;


  function HasdwFileFlags(FixedFileInfo: PVSFixedFileInfo; Flag : Word) : Boolean;
  begin
    Result := (FixedFileInfo.dwFileFlagsMask and
              FixedFileInfo.dwFileFlags and
              Flag) = Flag;
  end;

  function GetFixedFileInfo: PVSFixedFileInfo;
  begin
    if not VerQueryValue(VerBuf, '', Pointer(Result), VerBufLen) then
      Result := nil
  end;

  function GetInfo(const aKey: string): string;
  begin
    Result := '';
    VerKey := Format('\StringFileInfo\%.4x%.4x\%s',
              [LoWord(Integer(VerBufValue^)),
              HiWord(Integer(VerBufValue^)), aKey]);
    if VerQueryValue(VerBuf, PChar(VerKey),VerBufValue,VerBufLen) then
      Result := StrPas(VerBufValue);
  end;

  function QueryValue(const aValue: string): string;
  begin
    Result := '';
    // obtain version information about the specified file
    if GetFileVersionInfo(PChar(sAppNamePath), VerHandle, VerSize, VerBuf) and
      // return selected version information
      VerQueryValue(VerBuf, '\VarFileInfo\Translation', VerBufValue, VerBufLen) then
        Result := GetInfo(aValue);
  end;


begin
  // Initialize the Result
  with Result do
  begin
    FileType := '';
    CompanyName := '';
    FileDescription := '';
    FileVersion := '';
    InternalName := '';
    LegalCopyRight := '';
    LegalTradeMarks := '';
    OriginalFileName := '';
    ProductName := '';
    ProductVersion := '';
    Comments := '';
    SpecialBuildStr:= '';
    PrivateBuildStr := '';
    FileFunction := '';
    DebugBuild := False;
    Patched := False;
    PreRelease:= False;
    SpecialBuild:= False;
    PrivateBuild:= False;
    InfoInferred := False;
  end;

  // Get the file type
  if SHGetFileInfo(PChar(sAppNamePath), 0, rSHFI, SizeOf(rSHFI),
    SHGFI_TYPENAME) <> 0 then
  begin
    Result.FileType := rSHFI.szTypeName;
  end;

  iRet := SHGetFileInfo(PChar(sAppNamePath), 0, rSHFI, SizeOf(rSHFI), SHGFI_EXETYPE);
  if iRet <> 0 then
  begin
    // determine whether the OS can obtain version information
    VerSize := GetFileVersionInfoSize(PChar(sAppNamePath), VerHandle);
    if VerSize > 0 then
    begin
      VerBuf := AllocMem(VerSize);
      try
        with Result do
        begin
          CompanyName      := QueryValue('CompanyName');
          FileDescription  := QueryValue('FileDescription');
          FileVersion      := QueryValue('FileVersion');
          InternalName    := QueryValue('InternalName');
          LegalCopyRight  := QueryValue('LegalCopyRight');
          LegalTradeMarks  := QueryValue('LegalTradeMarks');
          OriginalFileName := QueryValue('OriginalFileName');
          ProductName      := QueryValue('ProductName');
          ProductVersion  := QueryValue('ProductVersion');
          Comments        := QueryValue('Comments');
          SpecialBuildStr  := QueryValue('SpecialBuild');
          PrivateBuildStr  := QueryValue('PrivateBuild');
          // Fill the  VS_FIXEDFILEINFO structure
          FixedFileInfo    := GetFixedFileInfo;
          DebugBuild      := HasdwFileFlags(FixedFileInfo,VS_FF_DEBUG);
          PreRelease      := HasdwFileFlags(FixedFileInfo,VS_FF_PRERELEASE);
          PrivateBuild    := HasdwFileFlags(FixedFileInfo,VS_FF_PRIVATEBUILD);
          SpecialBuild    := HasdwFileFlags(FixedFileInfo,VS_FF_SPECIALBUILD);
          Patched          := HasdwFileFlags(FixedFileInfo,VS_FF_PATCHED);
          InfoInferred    := HasdwFileFlags(FixedFileInfo,VS_FF_INFOINFERRED);
          FileFunction    := GetFileSubType(FixedFileInfo);
        end;
      finally
        FreeMem(VerBuf, VerSize);
      end
    end;
  end
end;

// Test it:

procedure TForm1.Button1Click(Sender: TObject);
var
  FvI: TFileVersionInfo;
const
  Tabulator: array[0..0] of Integer = (70);
  BoolValues: array[Boolean] of string = ('No', 'Yes');
begin
  FvI := FileVersionInfo('C:\version\test.exe');
  ListBox1.TabWidth := 1;
  SendMessage(ListBox1.Handle, LB_SETTABSTOPS, 1, Longint(@Tabulator));
  with FvI, ListBox1.Items do
  begin
    Add('FileType:'#9 + FileType);
    Add('CompanyName:'#9 + CompanyName);
    Add('CompanyName:'#9 + FileDescription);
    Add('FileVersion:'#9 + FileVersion);
    Add('InternalName:'#9 + InternalName);
    Add('LegalCopyRight:'#9 + LegalCopyRight);
    Add('LegalTradeMarks:'#9 + LegalTradeMarks);
    Add('OriginalFileName:'#9 + OriginalFileName);
    Add('ProductName:'#9 + ProductName);
    Add('ProductVersion:'#9 + ProductVersion);
    Add('SpecialBuildStr:'#9 + SpecialBuildStr);
    Add('PrivateBuildStr:'#9 + PrivateBuildStr);
    Add('FileFunction:'#9 + FileFunction);
    Add('DebugBuild:'#9 + BoolValues[DebugBuild]);
    Add('PreRelease:'#9 + BoolValues[PreRelease]);
    Add('PrivateBuild:'#9 + BoolValues[PrivateBuild]);
    Add('SpecialBuild:'#9 + BoolValues[SpecialBuild]);
  end;
end;


end.

i "button1" ændre du stien til exe filen som du vil have info om.

FvI := FileVersionInfo('C:\version\test.exe');

er der problemer?....

stone> tror du ikke han mener en .htm fil

Stoney

ja det er muligt men så havde det været nemmest at målrette spørgsmålet til en htm fil. de meta title osv. findes jo også i en exe fil.