精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● Delphi>>其他>>在程序中取得程序版本信息的例子

主题:在程序中取得程序版本信息的例子
发信人: teleme(PassWord)
整理人: teleme(2001-08-15 08:54:41), 站内信件
//************以下保存为MainFrm.dfm
object MainForm: TMainForm
  Left = 130
  Top = 135
  BorderStyle = bsDialog
  Caption = '版本信息'
  ClientHeight = 311
  ClientWidth = 457
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnShow = FormShow
  PixelsPerInch = 96
  TextHeight = 13
  object lvVersionInfo: TListView
    Left = 0
    Top = 0
    Width = 457
    Height = 257
    Align = alTop
    Columns = <
item
Caption = 'Key'
Width = 200
end
item
Caption = 'Value'
Width = 200
end>
    GridLines = True
    ReadOnly = True
    RowSelect = True
    TabOrder = 0
    ViewStyle = vsReport
  end
  object btnClose: TButton
    Left = 188
    Top = 268
    Width = 75
    Height = 25
    Caption = 'Close'
    TabOrder = 1
    OnClick = btnCloseClick
  end
end
//************以下保存为MainFrm.pas
unit MainFrm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, FileCtrl, StdCtrls, verinfo, Grids, Outline, DirOutln,
  ComCtrls;

type
  TMainForm = class(TForm)
    lvVersionInfo: TListView;
    btnClose: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
  private
    VerInfoRes: TVerInfoRes;
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure AddListViewItem(const aCaption, aValue: String; aData: Pointer;
  aLV: TListView);
// This method is used to add a TListItem to the TListView, aLV
var
  NewItem: TListItem;
begin
  NewItem := aLV.Items.Add;
  NewItem.Caption := aCaption;
  NewItem.Data := aData;
  NewItem.SubItems.Add(aValue);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  VerInfoRes := TVerInfoRes.Create(Application.ExeName);
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
  VerInfoRes.Free;
end;

procedure TMainForm.FormShow(Sender: TObject);
var
  VerString: String;
  i: integer;
  sFFlags: String;

begin
  for i := ord(viCompanyName) to ord(viComments) do begin
    VerString := VerInfoRes.GetPreDefKeyString(TVerInfoType(i));
    if VerString <> '' then
      AddListViewItem(VerNameArray[TVerInfoType(i)], VerString, nil,
        lvVersionInfo);
  end;
  VerString := VerInfoRes.GetUserDefKeyString('Author');
  if VerString <> EmptyStr then
      AddListViewItem('Author', VerString, nil, lvVersionInfo);
      

  AddListViewItem('File Version', VerInfoRes.FileVersion, nil,
    lvVersionInfo);
  AddListViewItem('Product Version', VerInfoRes.ProductVersion, nil,
    lvVersionInfo);
  for i := 0 to VerInfoRes.FileFlags.Count - 1 do begin
    if i <> 0 then
      sFFlags := SFFlags+', ';
    sFFlags := SFFlags+VerInfoRes.FileFlags[i];
  end;
  AddListViewItem('File Flags',SFFlags, nil, lvVersionInfo);
  AddListViewItem('Operating System', VerINfoRes.FileOS, nil, lvVersionInfo);

end;

procedure TMainForm.btnCloseClick(Sender: TObject);
begin
  Close;
end;

end.

//************以下保存为verinfo.pas

unit VerInfo;

interface

uses SysUtils, WinTypes, Dialogs, Classes;

type
  { define a generic exception class for version info, and an exception
    to indicate that no version info is available. }
  EVerInfoError   = class(Exception);
  ENoVerInfoError = class(Exception);
  eNoFixeVerInfo  = class(Exception);

  // define enum type representing different types of version info
  TVerInfoType =
    (viCompanyName,
     viFileDescription,
     viFileVersion,
     viInternalName,
     viLegalCopyright,
     viLegalTrademarks,
     viOriginalFilename,
     viProductName,
     viProductVersion,
     viComments);

const

  // define an array constant of strings representing the pre-defined
  // version information keys.
  VerNameArray: array[viCompanyName..viComments] of String[20] =
  ('CompanyName',
   'FileDescription',
   'FileVersion',
   'InternalName',
   'LegalCopyright',
   'LegalTrademarks',
   'OriginalFilename',
   'ProductName',
   'ProductVersion',
   'Comments');

type

  // Define the version info class
  TVerInfoRes = class
  private
    Handle            : DWord;
    Size              : Integer;
    RezBuffer         : String;
    TransTable        : PLongint;
    FixedFileInfoBuf  : PVSFixedFileInfo;
    FFileFlags        : TStringList;
    FFileName         : String;
    procedure FillFixedFileInfoBuf;
    procedure FillFileVersionInfo;
    procedure FillFileMaskInfo;
  protected
    function GetFileVersion   : String;
    function GetProductVersion: String;
    function GetFileOS        : String;
  public
    constructor Create(AFileName: String);
    destructor Destroy; override;
    function GetPreDefKeyString(AVerKind: TVerInfoType): String;
    function GetUserDefKeyString(AKey: String): String;
    property FileVersion    : String read GetFileVersion;
    property ProductVersion : String read GetProductVersion;
    property FileFlags      : TStringList read FFileFlags;
    property FileOS         : String read GetFileOS;
  end;

implementation

uses Windows;

const
  // strings that must be fed to VerQueryValue() function
  SFInfo                = '\StringFileInfo\';
  VerTranslation: PChar = '\VarFileInfo\Translation';
  FormatStr             = '%s%.4x%.4x\%s%s';


constructor TVerInfoRes.Create(AFileName: String);
begin
  FFileName := aFileName;
  FFileFlags := TStringList.Create;
  // Get the file version information
  FillFileVersionInfo;
  //Get the fixed file info
  FillFixedFileInfoBuf;
  // Get the file mask values
  FillFileMaskInfo;
end;


destructor TVerInfoRes.Destroy;
begin
  FFileFlags.Free;
end;

procedure TVerInfoRes.FillFileVersionInfo;
var
  SBSize: UInt;
begin
  // Determine size of version information
  Size := GetFileVersionInfoSize(PChar(FFileName), Handle);
  if Size <= 0 then { raise exception if size <= 0 }
raise ENoVerInfoError.Create('No Version Info Available.');

// Set the length accordingly
SetLength(RezBuffer, Size);
// Fill the buffer with version information, raise exception on error
if not GetFileVersionInfo(PChar(FFileName), Handle, Size, PChar(RezBuffer)) then
raise EVerInfoError.Create('Cannot obtain version info.');

// Get translation info, raise exception on error
if not VerQueryValue(PChar(RezBuffer), VerTranslation, pointer(TransTable),
SBSize) then
raise EVerInfoError.Create('No language info.');
end;

procedure TVerInfoRes.FillFixedFileInfoBuf;
var
Size: Cardinal;
begin
if VerQueryValue(PChar(RezBuffer), '\', Pointer(FixedFileInfoBuf), Size) then begin
if Size < SizeOf(TVSFixedFileInfo) then
raise eNoFixeVerInfo.Create('No fixed file info');
end
else
raise eNoFixeVerInfo.Create('No fixed file info')
end;

procedure TVerInfoRes.FillFileMaskInfo;
begin
with FixedFileInfoBuf^ do begin
if (dwFileFlagsMask and dwFileFlags and VS_FF_PRERELEASE) <> 0then
      FFileFlags.Add('Pre-release');
    if (dwFileFlagsMask and dwFileFlags and VS_FF_PRIVATEBUILD) <> 0 then
      FFileFlags.Add('Private build');
    if (dwFileFlagsMask and dwFileFlags and VS_FF_SPECIALBUILD) <> 0 then
      FFileFlags.Add('Special build');
    if (dwFileFlagsMask and dwFileFlags and VS_FF_DEBUG) <> 0 then
      FFileFlags.Add('Debug');
  end;
end;

function TVerInfoRes.GetPreDefKeyString(AVerKind: TVerInfoType): String;
var
  P: PChar;
  S: UInt;
begin
  Result := Format(FormatStr, [SfInfo, LoWord(TransTable^),HiWord(TransTable^),
    VerNameArray[aVerKind], #0]);
  // get and return version query info, return empty string on error
  if VerQueryValue(PChar(RezBuffer), @Result[1], Pointer(P), S) then
    Result := StrPas(P)
  else
    Result := '';
end;

function TVerInfoRes.GetUserDefKeyString(AKey: String): String;
var
  P: Pchar;
  S: UInt;
begin
  Result := Format(FormatStr, [SfInfo, LoWord(TransTable^),HiWord(TransTable^),
    aKey, #0]);
  // get and return version query info, return empty string on error
  if VerQueryValue(PChar(RezBuffer), @Result[1], Pointer(P), S) then
    Result := StrPas(P)
  else
    Result := '';
end;


function VersionString(Ms, Ls: Longint): String;
begin
  Result := Format('%d.%d.%d.%d', [HIWORD(Ms), LOWORD(Ms),
     HIWORD(Ls), LOWORD(Ls)]);
end;

function TVerInfoRes.GetFileVersion: String;
begin
  with FixedFileInfoBuf^ do
    Result := VersionString(dwFileVersionMS, dwFileVersionLS);
end;

function TVerInfoRes.GetProductVersion: String;
begin
  with FixedFileInfoBuf^ do
    Result := VersionString(dwProductVersionMS, dwProductVersionLS);
end;

function TVerInfoRes.GetFileOS: String;
begin
  with FixedFileInfoBuf^ do
    case dwFileOS of
      VOS_UNKNOWN:  // Same as VOS__BASE
        Result := 'Unknown';
      VOS_DOS:
        Result := 'Designed for MS-DOS';
      VOS_OS216:
        Result := 'Designed for 16-bit OS/2';
      VOS_OS232:
        Result := 'Designed for 32-bit OS/2';
      VOS_NT:
        Result := 'Designed for Windows NT';


      VOS__WINDOWS16:
        Result := 'Designed for 16-bit Windows';
      VOS__PM16:
        Result := 'Designed for 16-bit PM';
      VOS__PM32:
        Result := 'Designed for 32-bit PM';
      VOS__WINDOWS32:
        Result := 'Designed for 32-bit Windows';

      VOS_DOS_WINDOWS16:
        Result := 'Designed for 16-bit Windows, running on MS-DOS';
      VOS_DOS_WINDOWS32:
        Result := 'Designed for Win32 API, running on MS-DOS';
      VOS_OS216_PM16:
        Result := 'Designed for 16-bit PM, running on 16-bit OS/2';
      VOS_OS232_PM32:
        Result := 'Designed for 32-bit PM, running on 32-bit OS/2';
      VOS_NT_WINDOWS32:
        Result := 'Designed for Win32 API, running on Windows/NT';
    else
      Result := 'Unknown';
    end;
end;


end.

//*************项目文件Versinfo.dpr
program versinfo;

uses
  Forms,
  MainFrm in 'MainFrm.pas' {MainForm};

{$R *.RES}

begin
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.


----
Fire Engine   

     

[关闭][返回]