{--------------------------------------------------------------------------------------------------

  ApFileVersionInformation
  ========================
  With this component you can read version information from files. The information has to be saved
  in the Microsoft standard. Other formats can NOT be read because Windows API does not support
  these formats.

  License
  =======
  Copyright 2010, Armin Pfäffle <mail@armin-pfaeffle.de>

  Released under the MIT license.
  http://www.armin-pfaeffle.de/licenses/mit

  Changelog
  =========
  17.12.2010 - v1.0.0.1
    - Added support and packages for Delphi 7 - XE.

  29.11.2010 - v1.0.0.0
    - Initial release.

 --------------------------------------------------------------------------------------------------}

unit ApFileVersionInformation;

interface

uses
  SysUtils,
  ShellAPI,
  Windows,
  Classes;

type
{--------------------------------------------------------------------------------------------------
  Storage record for verion information data.
 --------------------------------------------------------------------------------------------------}
TApFileVersionInformation = record
  Filename,
  FileType,
  CompanyName,
  FileDescription,
  FileVersion,
  InternalName,
  LegalCopyRight,
  LegalTradeMarks,
  OriginalFileName,
  ProductName,
  ProductVersion,
  Comments,
  SpecialBuildStr,
  PrivateBuildStr,
  FileFunction : String;
  DebugBuild,
  PreRelease,
  SpecialBuild,
  PrivateBuild,
  Patched,
  InfoInferred : Boolean;
  AdditionalProperties: array of array[0..1] of String;
end;

{--------------------------------------------------------------------------------------------------
  Class for getting the version information of a file over the Windows API.
 --------------------------------------------------------------------------------------------------}
TApFileVersionInformationReader = class(TComponent)
private
  FApplicationVersionInformation : TApFileVersionInformation;
  FApplicationAdditionalKeys : TStringList;
  class procedure ClearVersionInformation(var VR: TApFileVersionInformation); {$IFDEF VER170} static; {$ENDIF}
  function GetApplicationVersionInformationHint(): String;
  procedure SetApplicationAdditionalKeys(Value: TStringList);
  procedure ChangeApplicationAdditionalKeys(Sender: TObject);
  procedure RefreshApplicationInfo();
public
  constructor Create(AOwner: TComponent); override;
  destructor Destroy(); override;

  class function Read(AFilename: String = ''): TApFileVersionInformation; overload; {$IFDEF VER170} static; {$ENDIF}
  class function Read(AdditionalKeys: array of String): TApFileVersionInformation; overload; {$IFDEF VER170} static; {$ENDIF}
  class function Read(AFilename: String; AdditionalKeys: array of String): TApFileVersionInformation; overload; {$IFDEF VER170} static; {$ENDIF}

  property ApplicationVersionInformation : TApFileVersionInformation read FApplicationVersionInformation;
published
  property ApplicationVersionInformationHint : String read GetApplicationVersionInformationHint;
  property ApplicationAdditionalKeys : TStringList read FApplicationAdditionalKeys write SetApplicationAdditionalKeys;
end;


procedure Register;

implementation

{--------------------------------------------------------------------------------------------------
  Registers component TApFileVersionInformationReader.
 --------------------------------------------------------------------------------------------------}
procedure Register;
begin
  RegisterComponents('ApUtilities', [TApFileVersionInformationReader]);
end;



{ TApFileVersionInformationReader }

{--------------------------------------------------------------------------------------------------
  This clears the current set information.
 --------------------------------------------------------------------------------------------------}
class procedure TApFileVersionInformationReader.ClearVersionInformation(var VR: TApFileVersionInformation);
begin
  with VR do
  begin
    Filename            := '';
    FileType            := '';
    CompanyName         := '';
    FileDescription     := '';
    FileVersion         := '';
    InternalName        := '';
    LegalCopyRight      := '';
    LegalTradeMarks     := '';
    OriginalFileName    := '';
    ProductName         := '';
    ProductVersion      := '';
    Comments            := '';
    SpecialBuildStr     := '';
    PrivateBuildStr     := '';
    FileFunction        := '';
    DebugBuild          := False;
    PreRelease          := False;
    SpecialBuild        := False;
    PrivateBuild        := False;
    Patched             := False;
    InfoInferred        := False;
  end;
end;

{--------------------------------------------------------------------------------------------------
  Returns a hint for design time: there is only access to FInfo in run time.
 --------------------------------------------------------------------------------------------------}
function TApFileVersionInformationReader.GetApplicationVersionInformationHint(): String;
begin
  if (csDesigning in ComponentState) then
    Result := 'ApplicationInfo property access only in run time.'
  else
    Result := 'You are in run time, so you have access to the info property.';
end;

{--------------------------------------------------------------------------------------------------
  Applies a new list of keys which should be read from version information ressource. With settings
  this news the FInfo property is updated.
 --------------------------------------------------------------------------------------------------}
procedure TApFileVersionInformationReader.SetApplicationAdditionalKeys(Value: TStringList);
begin
  if (FApplicationAdditionalKeys.Text <> Value.Text) then
    FApplicationAdditionalKeys.Assign(Value);
end;

{--------------------------------------------------------------------------------------------------

 --------------------------------------------------------------------------------------------------}
procedure TApFileVersionInformationReader.ChangeApplicationAdditionalKeys(Sender: TObject);
begin
  RefreshApplicationInfo();
end;

{--------------------------------------------------------------------------------------------------
  Re-Reads the version information if not in design time.
 --------------------------------------------------------------------------------------------------}
procedure TApFileVersionInformationReader.RefreshApplicationInfo();
var
  StrArray : array of String;
  i : Integer;
begin
  if (not (csDesigning in ComponentState)) then
  begin
    SetLength(StrArray, FApplicationAdditionalKeys.Count);
    for i := 0 to FApplicationAdditionalKeys.Count - 1 do
      StrArray[i] := FApplicationAdditionalKeys[i];
    FApplicationVersionInformation := TApFileVersionInformationReader.Read(StrArray);
  end;
end;

{--------------------------------------------------------------------------------------------------

 --------------------------------------------------------------------------------------------------}
constructor TApFileVersionInformationReader.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FApplicationAdditionalKeys := TStringList.Create();
  FApplicationAdditionalKeys.OnChange := ChangeApplicationAdditionalKeys;
  if (not (csDesigning in ComponentState)) then
    RefreshApplicationInfo();
end;

{--------------------------------------------------------------------------------------------------

 --------------------------------------------------------------------------------------------------}
destructor TApFileVersionInformationReader.Destroy();
begin
  FreeAndNil(FApplicationAdditionalKeys);
  inherited Destroy();
end;

{--------------------------------------------------------------------------------------------------
  Wrapper method for Read(Filename, AdditionalKeys) which returns version informations for given
  filename.
 --------------------------------------------------------------------------------------------------}
class function TApFileVersionInformationReader.Read(AFilename: String = ''): TApFileVersionInformation;
begin
  Result := Read(AFilename, []);
end;

{--------------------------------------------------------------------------------------------------
  Wrapper method for Read(Filename, AdditionalKeys) which returns version informations for current
  application. Additional parameters can be defined.
 --------------------------------------------------------------------------------------------------}
class function TApFileVersionInformationReader.Read(AdditionalKeys: array of String): TApFileVersionInformation;
begin
  Result := Read('', AdditionalKeys);
end;

{--------------------------------------------------------------------------------------------------
  Reads all valid version informations from given file via Windows API. File has to exist, when not
  a exceptions is thrown. The original code was submitted by Thomas Stutz on:
  http://www.swissdelphicenter.ch/torry/showcode.php?id=1047

  If AFilename parameter is empty ('') then it gets replaced with ParamStr(0) which is the current
  application filename.

  You can specifiy AdditionalKeys for special information parameters like "Last Compile" from
  DDevExtensions (http://andy.jgknet.de/blog/ide-tools/ddevextensions/).

  In some cases developer do NOT add version information the way Microsoft defined it so this code
  can NOT read the informations. Peter Johnson offers a DLL at delphiDabbler.com which can handle
  even such non-standard definitions (http://www.delphidabbler.com/software/vibindata/main).
 --------------------------------------------------------------------------------------------------}
class function TApFileVersionInformationReader.Read(AFilename: String; AdditionalKeys: array of String): TApFileVersionInformation;
var
  rSHFI : TSHFileInfo;
  VerSize : Integer;
  VerBuf : PChar;
  VerBufValue : Pointer;
  VerHandle : Cardinal;
  VerBufLen : Cardinal;
  VerKey : String;
  FixedFileInfo : PVSFixedFileInfo;
  i : Integer;

  // 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(PChar(VerBufValue));
  end;

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

begin
  // Clear current values
  ClearVersionInformation(Result);

  // If Filename parameter is empty then load information of application
  if (AFilename = '') then
    AFilename := ParamStr(0);
  Result.Filename := AFilename;

  // Check filename
  if (not FileExists(AFilename)) then
    raise Exception.Create('File does not exist.');

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

  // determine whether the OS can obtain version information
  VerSize := GetFileVersionInfoSize(PChar(AFilename), 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');

        SetLength(AdditionalProperties, Length(AdditionalKeys));
        for i := 0 to Length(AdditionalKeys) - 1 do
        begin
          AdditionalProperties[i][0] := AdditionalKeys[i];
          AdditionalProperties[i][1] := QueryValue(AdditionalKeys[i]);
        end;

        // 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.

