Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue38/System/VersionInfo.pas

Pascal/Delphi Source File | 1998-08-12 | 8.5 KB | 253 lines

unit VersionInfo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ExptIntf, ToolIntf;

type
    TVersionInfo = class(TComponent)
    private
        { Private declarations }
        fTimer: TTimer;
        fFileAge: Integer;
        fVersionData: PChar;
        fVerStrings: TStringList;
        fExecutableFileName: String;
        procedure ReadOnlyStringProperty (Index: Integer; const Value: String);
        procedure ReadOnlyIntegerProperty (Index, Value: Integer);
        procedure SetVersionStrings (Value: TStringList);
        function GetIndexStringProperty (Index: Integer): String;
        function GetIndexIntegerProperty (Index: Integer): Integer;
        procedure TimerRefresh (Sender: TObject);
        procedure Refresh;
        procedure ParseVersionData;
        function GetKey (const KeyName: String): String;
    protected
        { Protected declarations }
    public
        { Public declarations }
        constructor Create (AOwner: TComponent); override;
        destructor Destroy; override;
        property Key [const KeyName: String]: String read GetKey;
    published
        { Published declarations }
        property ExecutableFileName: String index 0 read GetIndexStringProperty write ReadOnlyStringProperty;
        property CompanyName: String index 1 read GetIndexStringProperty write ReadOnlyStringProperty;
        property FileDescription: String index 2 read GetIndexStringProperty write ReadOnlyStringProperty;
        property FileVersion: String index 3 read GetIndexStringProperty write ReadOnlyStringProperty;
        property InternalName: String index 4 read GetIndexStringProperty write ReadOnlyStringProperty;
        property LegalCopyright: String index 5 read GetIndexStringProperty write ReadOnlyStringProperty;
        property LegalTrademarks: String index 6 read GetIndexStringProperty write ReadOnlyStringProperty;
        property OriginalFilename: String index 7 read GetIndexStringProperty write ReadOnlyStringProperty;
        property ProductName: String index 8 read GetIndexStringProperty write ReadOnlyStringProperty;
        property ProductVersion: String index 9 read GetIndexStringProperty write ReadOnlyStringProperty;
        property Comments: String index 10 read GetIndexStringProperty write ReadOnlyStringProperty;
        property Keys: TStringList read fVerStrings write SetVersionStrings;
        property FileVersionHigh: Integer index $30 read GetIndexIntegerProperty write ReadOnlyIntegerProperty;
        property FileVersionLow: Integer index $34 read GetIndexIntegerProperty write ReadOnlyIntegerProperty;
        property ProductVersionHigh: Integer index $38 read GetIndexIntegerProperty write ReadOnlyIntegerProperty;
        property ProductVersionLow: Integer index $3C read GetIndexIntegerProperty write ReadOnlyIntegerProperty;
    end;

procedure Register;

implementation

{ TVersionInfo }

constructor TVersionInfo.Create (AOwner: TComponent);
begin
    Inherited Create (AOwner);
    fFileAge := -1;
    fVersionData := Nil;
    fVerStrings := TStringList.Create;
    if ToolServices = Nil then begin
        // Run-time case
        fExecutableFileName := Application.ExeName;
        Refresh;
    end else begin
        // Design-time case
        fTimer := TTimer.Create (Self);
        fTimer.Enabled := True;
        fTimer.Interval := 500;
        fTimer.OnTimer := Self.TimerRefresh;
        fExecutableFileName := ToolServices.GetProjectName;
        if fExecutableFileName <> '' then fExecutableFileName := ChangeFileExt (fExecutableFileName, '.exe');
    end;
end;

destructor TVersionInfo.Destroy;
begin
    if ToolServices <> Nil then fTimer.Free;
    if fVersionData <> Nil then FreeMem (fVersionData);
    fVerStrings.Free;
    Inherited Destroy;
end;

procedure TVersionInfo.Refresh;
var
    pSrc: PChar;
    hMod: hModule;
    Res: hRsrc;
    lRes: hGlobal;
begin
    // Trash the existing version data buffer
    if fVersionData <> Nil then FreeMem (fVersionData);
    fVersionData := Nil;

    // Now get the updated stuff....
    if fExecutableFileName <> '' then begin
        hMod := LoadLibraryEx (PChar (fExecutableFileName), 0, Load_Library_As_DataFile);
        if hMod <> 0 then try
            Res := FindResource (hMod, PChar (1), rt_Version);
            if Res <> 0 then begin
                lRes := LoadResource (hMod, Res);
                if lRes <> 0 then begin
                    pSrc := LockResource (lRes);
                    if pSrc <> Nil then begin
                        // Sanity check time!
                        if PWideChar (pSrc + 6) = 'VS_VERSION_INFO' then begin
                            GetMem (fVersionData, SizeofResource (hmod, Res));
                            Move (pSrc^, fVersionData^, SizeofResource (hmod, Res));
                            ParseVersionData;
                        end;
                    end;
                end;
            end;
        finally
            FreeLibrary (hMod);
        end;
    end;
end;

procedure TVersionInfo.ReadOnlyStringProperty (Index: Integer; const Value: String);
begin
    // Read-only property
end;

procedure TVersionInfo.ReadOnlyIntegerProperty (Index, Value: Integer);
begin
    // Read-only property
end;

procedure TVersionInfo.SetVersionStrings (Value: TStringList);
begin
    // Read-only property
end;

procedure TVersionInfo.TimerRefresh (Sender: TObject);
var
    AgeNow: Integer;
begin
    AgeNow := FileAge (fExecutableFileName);
    if AgeNow <> fFileAge then begin
        // Executable has been freshened, newly created or deleted
        fFileAge := AgeNow;
        Refresh;
    end;
end;

procedure TVersionInfo.ParseVersionData;
const
    //---------------------------------------------------
    // ACHTUNG!  Don't change these constants unless the
    // format of the VERSION resource is altered.
    //---------------------------------------------------
    vSFIStart = $5C;              // Start of StringFileInfo block
    vSTStart  = vSFIStart + $24;  // Start of String table block
    vSStart   = vSTStart + $18;   // Start of String table proper
var
    p: PChar;
    pw: PWord absolute p;
    StringFileInfoLen, ThisEntryLen: Word;
    Key, Val: String;

    function Align32 (p: PChar): PChar;
    var
        pp: LongInt absolute p;
    begin
        pp := (pp + 3) and $fffffffc;
        Result := p;
    end;

begin
    // You can never have too many sanity checks...
    if PWideChar (fVersionData + vSFIStart + 6) <> 'StringFileInfo' then
        raise Exception.Create ('Unrecognised version block');
    // Looks good - parse the version strings
    fVerStrings.Clear;
    p := fVersionData + vSTStart;
    StringFileInfoLen := pw^;
    // Point at first entry
    p := fVersionData + vSStart;
    while p < (fVersionData + vSTStart + StringFileInfoLen) do begin
        ThisEntryLen := pw^;
        Key := PWideChar (p + 6);
        Val := PWideChar ((Align32 (p + 6 + ((Length (Key) + 1) * 2))));
        fVerStrings.Add (Key + '=' + Val);
        p := Align32 (p + ThisEntryLen);
    end;
end;

function TVersionInfo.GetKey (const KeyName: String): String;
var
    S: String;
    Index, nPos: Integer;
begin
    if fVersionData = Nil then Result := '--not available--' else begin
       for Index := 0 to fVerStrings.Count - 1 do begin
           S := fVerStrings [Index];
           nPos := Pos ('=', S);
           if Copy (S, 1, nPos - 1) = KeyName then begin
               Result := Copy (S, nPos + 1, MaxInt);
               Exit;
           end;
       end;

       Result := '';
    end;
end;

function TVersionInfo.GetIndexStringProperty (Index: Integer): String;
const
    PropName: array [1..10] of String = (

              'CompanyName',
              'FileDescription',
              'FileVersion',
              'InternalName',
              'LegalCopyright',
              'LegalTrademarks',
              'OriginalFilename',
              'ProductName',
              'ProductVersion',
              'Comments'                );
begin
    case Index of
        0:     Result := fExecutableFileName;
        1..10: Result := GetKey (PropName [Index]);
    end;
end;

function TVersionInfo.GetIndexIntegerProperty (Index: Integer): Integer;
begin
    if fVersionData = Nil then Result := -1 else
       Result := PInteger (fVersionData + Index)^;
end;

procedure Register;
begin
    RegisterComponents ('The X Factor', [TVersionInfo]);
end;

end.