ProGestion/Base/InfoProject.pas

{
===============================================================================
  Copyright (©) 2005. Rodax Software.
===============================================================================
  Los contenidos de este fichero son propiedad de Rodax Software titular del
  copyright. Este fichero sólo podrá ser copiado, distribuido y utilizado,
  en su totalidad o en parte, con el permiso escrito de Rodax Software, o de
  acuerdo con los términos y condiciones establecidas en el acuerdo/contrato
  bajo el que se suministra.
  -----------------------------------------------------------------------------
  Web:  www.rodax-software.com
===============================================================================
  Fecha primera versión: 17-05-2005
  Versión actual: 1.0.0
  Fecha versión actual: 17-05-2005
===============================================================================
  Modificaciones:

    Fecha         Comentarios
    ---------------------------------------------------------------------------
===============================================================================
}
unit InfoProject;

interface

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

type
  TInfoProject = class(TComponent)
  private
    { Private declarations }
    FFVIBuff: Pointer;
    FFVISize: DWord;
    FHandle: DWord;
    FFileName: String;
    FLanguage: Word;
    FCodePage: Word;
    FLanguageCodePage: String;
    FCompanyName: String;
    FFileDescription: String;
    FFileVersion: String;
    FInternalName: String;
    FLegalCopyright: String;
    FLegalTradeMarks: String;
    FOriginalFileName: String;
    FProductName: String;
    FProductVersion: String;
    FComments: String;
    procedure ReadFixedFileInfo;
    function GetLangCPage: String;
    function GetStringFileInfo(S: String): String;
    procedure SetFileName(const Value: String);
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    function LanguageStr(Language: Word): String;
    property FileName: String read FFileName write SetFileName;
    property Language: Word read FLanguage;
    property CodePage: Word read FCodePage;
    property LanguageCodePage: String read FLanguageCodePage;
    property CompanyName: String read FCompanyName;
    property FileDescription: String read FFileDescription;
    property FileVersion: String read FFileVersion;
    property InternalName: String read FInternalName;
    property LegalCopyright: String read FLegalCopyright;
    property LegalTradeMarks: String read FLegalTradeMarks;
    property OriginalFileName: String read FOriginalFileName;
    property ProductName: String read FProductName;
    property ProductVersion: String read FProductVersion;
    property Comments: String read FComments;
  published
    { Published declarations }
  end;

implementation

{ TInfoProject }

constructor TInfoProject.Create(AOwner: TComponent);
begin  { of TInfoProject.Create }
  inherited Create(AOwner);

  { build current EXE filename }
  FileName := ParamStr(0);
end;   { of TInfoProject.Create }

procedure   TInfoProject.ReadFixedFileInfo;
begin  { of TInfoProject.ReadFixedFileInfo }
  { determine size of buffer required }
  FFVISize := GetFileVersionInfoSize(PChar(FileName), FHandle);

  { create buffer }
  GetMem(FFVIBuff, FFVISize);
  try

    { load buffer }
    GetFileVersionInfo(PChar(FileName), FHandle, FFVISize, FFVIBuff);

    { extract the language/codepage info }
    FLanguageCodePage := GetLangCPage;

    { extract the other info }
    FCompanyName := GetStringFileInfo('CompanyName');
    FFileDescription := GetStringFileInfo('FileDescription');
    FFileVersion := GetStringFileInfo('FileVersion');
    FInternalName := GetStringFileInfo('InternalName');
    FLegalCopyright := GetStringFileInfo('LegalCopyright');
    FLegalTradeMarks := GetStringFileInfo('LegalTradeMarks');
    FOriginalFileName := GetStringFileInfo('OriginalFileName');
    FProductName := GetStringFileInfo('ProductName');
    FProductVersion := GetStringFileInfo('ProductVersion');
    FComments := GetStringFileInfo('Comments');

  finally
    { dispose buffer }
    FreeMem(FFVIBuff, FFVISize);
  end;
end;   { of TInfoProject.ReadFixedFileInfo }

function    TInfoProject.LanguageStr(Language: Word): String;
var
  P: array[0..255] of Char;
  Len: Word;
begin  { of TInfoProject.LanguageStr }
  Len := VerLanguageName(Language, P, SizeOf(P));
  if (Len > SizeOf(P)) then
    begin
      { if this occurs then the P buffer is too small }
      { so we will truncate the returned string }
      Len := SizeOf(P);
    end;
  SetString(Result, P, Len);
end;   { of TInfoProject.LanguageStr }

function    TInfoProject.GetLangCPage: String;
var
  SearchString: String;
  FVILang: array of Byte;
  Len: DWORD;
begin  { of TInfoProject.GetLangCPage }
  Result := '00000000';
  if (FFVIBuff <> NIL) then
    begin
      SearchString := '\VarFileInfo\Translation';
      if VerQueryValue(FFVIBuff, PChar(SearchString),
         Pointer(FVILang), Len) then
        begin
          FLanguage := FVILang[0] + FVILang[1]*$100;
          FCodePage := FVILang[2] + FVILang[3]*$100;
          Result := IntToHex(FLanguage, 4) + IntToHex(FCodePage, 4);
        end;
    end;
end;   { of TInfoProject.GetLangCPage }

function    TInfoProject.GetStringFileInfo(S: String): String;
var
  SearchString: String;
  P: PChar;
  Len: DWORD;
begin  { of TInfoProject.GetStringFileInfo }
  Result := '';
  if (FFVIBuff <> NIL) then
    begin
      SearchString := '\StringFileInfo\'+FLanguageCodePage+'\'+S;
      if VerQueryValue(FFVIBuff, PChar(SearchString), Pointer(P), Len) then
        begin
          { coded with StrLen to ditch the trailing #0 character }
          SetString(Result, P, StrLen(P));
        end;
    end;
end;   { of TInfoProject.GetStringFileInfo }

procedure   TInfoProject.SetFileName(const Value: String);
begin  { of TInfoProject.SetFileName }
  FFileName := ExpandUNCFileName(Value);

  { read fileinfo from this new file }
  ReadFixedFileInfo;

end;   { of TInfoProject.SetFileName }

end.