(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)

unit AHMTVersionLabel;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, StdCtrls,AHMStdClass,AHMStandardConst;

type
  TAHMVersionRes = (verCompanyName, verFileDescription, verFileVersion,
                    verInternalName,verLegalCopyright, verOriginalFilename,
                    verProductName, verProductVersion, verComments, verFlags);
  TAHMVersionLabel = class(TLabel)
  private
    FVersionResource: TAHMVersionRes;
    FInfoPrefix: string;
    FShowInfoPrefix: boolean;
    FVersionResourceKey: string;
    FLangCharset: string;
    FAboutStr : TAHMAboutSControlStr;
    procedure SetupInfoPrefix;
    procedure SetupResourceKey;
    function GetStringFileInfo(Buffer: Pchar; size: integer): string;
    function GetFixedFileInfo(Buffer: PChar; size: integer): string;
    function GetInfo: string;
    procedure SetupCaption;
  protected
    procedure SetInfoPrefix(Value: String);
    function GetInfoPrefix: string;
    procedure SetShowInfoPrefix(Value: boolean);
    procedure SetVersionResKey(Value: string);
    procedure SetLangCharset(Value: string);
    procedure SetVersionResource(Value: TAHMVersionRes);
  public
    constructor Create(AOwner: TComponent); override;
  published
    property About : TAHMAboutSControlStr read FAboutStr write FAboutStr;
    property VersionRes: TAHMVersionRes read FVersionResource write SetVersionResource default verFileVersion;
    property VersionResKey: String read FVersionResourceKey write SetVersionResKey;
    property InfoPrefix: String read GetInfoPrefix write SetInfoPrefix;
    property ShowInfoPrefix: boolean read FShowInfoPrefix write SetShowInfoPrefix default true;
    property LangCharset: string read FLangCharset write SetLangCharset;
    property WordWrap;
    property Align;
    property Color;
    property Font;
    property AutoSize;
    property Alignment;
    property ParentFont;
  end;

const
  VersionLookup: array[TAHMVersionRes, 0..1] of string = (
  ('CompanyName', 'Company Name:'),
  ('FileDescription', 'File Description:'),
  ('FileVersion', 'File Version:'),
  ('InternalName', 'Internal Name:'),
  ('LegalCopyright', 'Legal Copyright:'),
  ('OriginalFilename', 'Original Filename:'),
  ('ProductName', 'Product Name:'),
  ('ProductVersion', 'Product Version:'),
  ('Comments', 'Comments:'),
  ('Flags', 'Flags:'));

implementation
uses Forms;

constructor TAHMVersionLabel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  WordWrap := false;
  Autosize := true;
  ShowInfoPrefix := true;
  LangCharset :='-1';
  VersionRes := verFileVersion;
end;

procedure TAHMVersionLabel.SetVersionResource(Value: TAHMVersionRes);
begin
  if FVersionResource<>Value then
  begin
    FVersionResource := Value;
    SetupResourceKey;
    SetupInfoPrefix;
  end;
end;

procedure TAHMVersionLabel.SetupResourceKey;
begin
  VersionResKey:=VersionLookup[FVersionResource, 0];
end;

function TAHMVersionLabel.GetFixedFileInfo(Buffer: PChar; size: integer): string;
var ValLen: DWord;
    FixedFileInfo: PVSFixedFileInfo;
begin
  if VerQueryValue(buffer, '\', Pointer(FixedFileInfo), ValLen) then
  begin
    Result := '';
    if (ValLen > 1) then
    begin
      if FixedFileInfo.dwFileFlags and VS_FF_DEBUG <> 0 then Result:=Result+',Debug Build';
      if FixedFileInfo.dwFileFlags and VS_FF_PRERELEASE <> 0 then Result:=Result+', Pre-Release Build';
      if FixedFileInfo.dwFileFlags and VS_FF_PATCHED <> 0 then Result:=Result+', Patched Build';
      if FixedFileInfo.dwFileFlags and VS_FF_PRIVATEBUILD <> 0 then Result:=Result+', Private Build';
      if FixedFileInfo.dwFileFlags and VS_FF_INFOINFERRED <> 0 then Result:=Result+', InfoInferred';
      if FixedFileInfo.dwFileFlags and VS_FF_SPECIALBUILD <> 0 then Result:=Result+', Special Build';
      if result <> '' then if Result[1] = ',' then Delete(Result, 1, 2);
    end;
  end else Result := '< Error retrieving version info >';
end;

function TAHMVersionLabel.GetStringFileInfo(Buffer: Pchar; size: integer): string;
var Vallen,Translen: DWord;
    VersionPointer, TransBuffer: pchar;
    Temp: integer;
    CalcLangCharSet: string;
begin
  if FLangCharSet = '-1' then
  begin
    VerQueryValue(buffer, '\VarFileInfo\Translation',pointer(TransBuffer), TransLen);
    if TransLen >= 4 then
    begin
      StrLCopy(@temp, TransBuffer, 2);
      CalcLangCharSet:=IntToHex(temp, 4);
      StrLCopy(@temp, TransBuffer+2, 2);
      CalcLangCharSet := CalcLangCharSet+IntToHex(temp, 4);
      FLangCharSet := CalcLangCharSet;
    end else
    begin
      Result := '< Error retrieving translation info >';
      exit;
    end;
  end;
  if VerQueryValue(buffer, pchar('\StringFileInfo\'+FLangCharSet+'\'+VersionResKey),
                     pointer(VersionPointer), vallen) then
  begin
    if (Vallen > 1) then
    begin
      SetLength(Result, vallen);
      StrLCopy(Pchar(Result), VersionPointer, vallen);
    end else Result := '< No Version Info >';
  end else result := '< Error retrieving version info >';
end;

function TAHMVersionLabel.GetInfo: string;
var Dump:DWord;
    Size: integer;
    buffer: pchar;
begin
  if csDesigning in Self.ComponentState then result := ahmrcstdnodesign else
  begin
    size := GetFileVersionInfoSize(pchar(Application.Exename), dump);
    if  size = 0 then
    begin
      Result := ahmrcstdnodata;
    end else
    begin
      buffer := StrAlloc(size+1);
      try
        if not GetFileVersionInfo(Pchar(Application.Exename), 0,size, buffer) then
        result := '< Error retrieving version info >' else
        begin
          if FVersionResource = verFlags then Result:=GetFixedFileInfo(buffer, size)
                                        else Result:=GetStringFileInfo(buffer, size);
        end;
      finally
        StrDispose(Buffer);
      end;
    end;
  end;
  if ShowInfoPrefix then Result := InfoPrefix+' '+Result;
end;

procedure TAHMVersionLabel.SetInfoPrefix(Value: String);
begin
  if FInfoPrefix = Value then exit;
  FInfoPrefix := Value;
  SetupCaption;
end;

procedure TAHMVersionLabel.SetVersionResKey(Value: string);
begin
  if FVersionResourceKey = Value then exit;
  FVersionResourceKey := Value;
  InfoPrefix := Value;
end;

function TAHMVersionLabel.GetInfoPrefix: string;
begin
  result := FInfoPrefix;
end;

procedure TAHMVersionLabel.SetShowInfoPrefix(Value: boolean);
begin
  if FShowInfoPrefix<>value then
  begin
    FShowInfoPrefix := Value;
    SetupCaption; 
  end;
end;

procedure TAHMVersionLabel.SetLangCharset(Value: string);
begin
  if FLangCharSet<>Value then
  begin
    FLangCharSet := Value;
    SetupCaption; 
  end;
end;

procedure TAHMVersionLabel.SetupInfoPrefix;
begin
  InfoPrefix := VersionLookup[FVersionResource,1];
end;

procedure TAHMVersionLabel.SetupCaption;
begin
  Caption := GetInfo;
end;

end.
