1 (*
2 * The contents of this file are subject to the Mozilla Public License
3 * Version 1.1 (the "License"); you may not use this file except in
4 * compliance with the License. You may obtain a copy of the License at
5 * http://www.mozilla.org/MPL/
6 *
7 * Software distributed under the License is distributed on an "AS IS"
8 * basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
9 * License for the specific language governing rights and limitations
10 * under the License.
11 *
12 * The Initial Developer of this code is John Hansen.
13 * Portions created by John Hansen are Copyright (C) 2009 John Hansen.
14 * All Rights Reserved.
15 *
16 *)
17 unit uVersionInfo;
18
19 interface
20
21 type
22 TVersionAttributes = record
23 PrivateBuild : Boolean;
24 SpecialBuild : Boolean;
25 PreRelease : Boolean;
26 Debug : Boolean;
27 InfoInferred : Boolean;
28 Patched : Boolean;
29 end;
30
31 TVersionInfo = record
32 CompanyName : String;
33 FileDescription : String;
34 FileVersion : String;
35 InternalName : String;
36 LegalCopyright : String;
37 OriginalFileName : String;
38 ProductName : String;
39 ProductVersion : String;
40 Comments : String;
41 FileFlags : TVersionAttributes;
42 end;
43
GetVersionInfonull44 function GetVersionInfo(const FileName: String): TVersionInfo;
GetProductVersionnull45 function GetProductVersion : string;
46
47 var
48 VerCompanyName : string = '';
49 VerFileDescription : string = '';
50 VerFileVersion : string = '';
51 VerInternalName : string = '';
52 VerLegalCopyright : string = '';
53 VerOriginalFileName : string = '';
54 VerProductName : string = '';
55 VerProductVersion : string = '';
56 VerComments : string = '';
57
58
59 implementation
60
61 uses
62 {$IFNDEF FPC}
63 Windows,
64 {$ENDIF}
65 SysUtils;
66
67 {$IFNDEF FPC}
GetProductVersionnull68 function GetProductVersion : string;
69 var
70 VI : TVersionInfo;
71 begin
72 VI := GetVersionInfo(ParamStr(0));
73 Result := VI.ProductVersion;
74 end;
75
GetVersionInfonull76 function GetVersionInfo(const FileName: String): TVersionInfo;
77 var
78 PBlock : Pointer;
79 BlockSize : Cardinal;
80 Dummy : DWORD;
81 Name : Array[0..1024] of Char;
82 V : TVersionInfo;
83 pTransTable: PLongint;
84 sFileInfo: string;
85
VerValuenull86 function VerValue(P: Pointer;Value: String): String;
87 var
88 Dummy : UINT;
89 Buffer : Pointer;
90 S : String;
91 B : Array[0..1024] of Char;
92 T : Array[0..1024] of Char;
93 begin
94 S := sFileInfo + Value ;
95 StrPCopy(B,S);
96 Buffer := @T[1] ;
97 VerQueryValue(P,B,Buffer,Dummy);
98 Result := StrPas(Buffer);
99 end;
100
AnalyzeFlagsnull101 function AnalyzeFlags(const AFileFlags : Integer) : TVersionAttributes;
102 var sflag,dflag, pflag, rflag, vflag, iflag : integer;
103 temp : TVersionAttributes;
104 begin
105 temp.SpecialBuild := False;
106 temp.PrivateBuild := False;
107 temp.PreRelease := False;
108 temp.Debug := False;
109 temp.InfoInferred := False;
110 temp.Patched := False;
111
112 // and returns type according to operand types
113 sflag := AFileFlags and VS_FF_SPECIALBUILD;
114 dflag := AFileFlags and VS_FF_DEBUG;
115 rflag := AFileFlags and VS_FF_PRERELEASE;
116 pflag := AFileFlags and VS_FF_PATCHED;
117 vflag := AFileFlags and VS_FF_PRIVATEBUILD;
118 iflag := AFileFlags and VS_FF_INFOINFERRED;
119
120 if (sflag = VS_FF_SPECIALBUILD) then
121 temp.SpecialBuild := True;
122
123 if (dflag = VS_FF_DEBUG) then
124 temp.Debug := True;
125
126 if (rflag = VS_FF_PRERELEASE) then
127 temp.PreRelease := True;
128
129 if (pflag = VS_FF_PATCHED) then
130 temp.Patched := True;
131
132 if (vflag = VS_FF_PRIVATEBUILD) then
133 temp.PrivateBuild := True;
134
135 if (iflag = VS_FF_INFOINFERRED) then
136 temp.InfoInferred := True;
137
138 Result := temp;
139 end;
140
141 // get the fixed file attribute -FileFlags
VerFixedValuenull142 function VerFixedValue(P: Pointer): TVersionAttributes;
143 var
144 Dummy : UINT;
145 Buffer : Pointer;
146 sts : Boolean;
147 S : String;
148 B : Array[0..1024] of Char;
149 T : Array[0..1024] of Char;
150 Fl : DWord;
151 V : PVSFixedFileInfo;
152 begin
153 S := '\';
154 StrPCopy(B,S);
155 Buffer := @T[1] ;
156 sts := VerQueryValue(P,B,Buffer,Dummy);
157
158 if sts then
159 begin
160 V := Buffer;
161 Fl := V.dwFileFlags;
162 Result := AnalyzeFlags(Fl);
163 end;
164 end;
165
166 begin
167 StrPCopy(Name, FileName);
168 BlockSize := GetFileVersionInfoSize(Name,Dummy);
169
170 if BlockSize > 0 then begin
171 GetMem(PBlock,2*BlockSize);
172 try
173 if GetFileVersionInfo(Name,Dummy,BlockSize,PBlock) then begin
174 if VerQueryValue(PBlock, '\VarFileInfo\Translation', Pointer(pTransTable), BlockSize) then
175 sFileInfo := Format('\StringFileInfo\%.4x%.4x\', [LoWord(pTransTable^), HiWord(pTransTable^)])
176 else
177 sFileInfo := '\StringFileInfo\040904e4\';
178 V.CompanyName := VerValue(PBlock,'CompanyName');
179 V.FileDescription := VerValue(PBlock,'FileDescription');
180 V.FileVersion := VerValue(PBlock,'FileVersion');
181 V.InternalName := VerValue(PBlock,'InternalName');
182 V.LegalCopyright := VerValue(PBlock,'LegalCopyright');
183 V.OriginalFileName := VerValue(PBlock,'OriginalFileName');
184 V.ProductName := VerValue(PBlock,'ProductName');
185 V.ProductVersion := VerValue(PBlock,'ProductVersion');
186 V.Comments := VerValue(PBlock,'Comments');
187 V.FileFlags := VerFixedValue(PBlock);
188 end;
189 finally
190 FreeMem(PBlock);
191 end;
192 end;
193 Result := V ;
194 end;
195
196 {$ELSE}
197
VerFixedValuenull198 function VerFixedValue: TVersionAttributes;
199 begin
200 Result.PrivateBuild := False;
201 Result.SpecialBuild := False;
202 Result.PreRelease := False;
203 Result.Debug := False;
204 Result.InfoInferred := False;
205 Result.Patched := False;
206 end;
207
GetProductVersionnull208 function GetProductVersion : string;
209 begin
210 Result := VerProductVersion;
211 end;
212
GetVersionInfonull213 function GetVersionInfo(const FileName: String): TVersionInfo;
214 begin
215 Result.CompanyName := VerCompanyName;
216 Result.FileDescription := VerFileDescription;
217 Result.FileVersion := VerFileVersion;
218 Result.InternalName := VerInternalName;
219 Result.LegalCopyright := VerLegalCopyright;
220 Result.OriginalFileName := VerOriginalFileName;
221 Result.ProductName := VerProductName;
222 Result.ProductVersion := VerProductVersion;
223 Result.Comments := VerComments;
224 Result.FileFlags := VerFixedValue;
225 if FileName = 'xyzzy' then
226 Result.Comments := FileName;
227 end;
228
229 {$ENDIF}
230
231
232 end.
233