HTML source code from TWebBrowser - How to detect Stream encoding? - delphi

Based on this question: How can I get HTML source code from TWebBrowser
If I run this code with a html page that has Unicode code page, the result is gibberish becouse TStringStream is not Unicode in D7. the page might be UTF8 encoded or other (Ansi) code page encoded.
How can I detect if a TStream/IPersistStreamInit is Unicode/UTF8/Ansi?
How do I always return correct result as WideString for this function?
function GetWebBrowserHTML(const WebBrowser: TWebBrowser): WideString;
If I replace TStringStream with TMemoryStream, and save TMemoryStream to file it's all good. It can be either Unicode/UTF8/Ansi. but I always want to return the stream back as WideString:
function GetWebBrowserHTML(const WebBrowser: TWebBrowser): WideString;
var
// LStream: TStringStream;
LStream: TMemoryStream;
Stream : IStream;
LPersistStreamInit : IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then exit;
// LStream := TStringStream.Create('');
LStream := TMemoryStream.Create;
try
LPersistStreamInit := WebBrowser.Document as IPersistStreamInit;
Stream := TStreamAdapter.Create(LStream,soReference);
LPersistStreamInit.Save(Stream,true);
// result := LStream.DataString;
LStream.SaveToFile('c:\test\test.txt'); // test only - file is ok
Result := ??? // WideString
finally
LStream.Free();
end;
end;
EDIT: I found this article - How to load and save documents in TWebBrowser in a Delphi-like way
Which does exactlly what I need. but it works correctlly only with Delphi Unicode compilers (D2009+). read Conclusion section:
There is obviously a lot more we could do. A couple of things
immediately spring to mind. We retro-fit some of the Unicode
functionality and support for non-ANSI encodings to the pre-Unicode
compiler code. The present code when compiled with anything earlier
than Delphi 2009 will not save document content to strings correctly
if the document character set is not ANSI.
The magic is obviously in TEncoding class (TEncoding.GetBufferEncoding). but D7 does not have TEncoding. Any ideas?

I used GpTextStream to handle the convertion (Should work for all Delphi versions):
function GetCodePageFromHTMLCharSet(Charset: WideString): Word;
const
WIN_CHARSET = 'windows-';
ISO_CHARSET = 'iso-';
var
S: string;
begin
Result := 0;
if Charset = 'unicode' then
Result := CP_UNICODE else
if Charset = 'utf-8' then
Result := CP_UTF8 else
if Pos(WIN_CHARSET, Charset) <> 0 then
begin
S := Copy(Charset, Length(WIN_CHARSET) + 1, Maxint);
Result := StrToIntDef(S, 0);
end else
if Pos(ISO_CHARSET, Charset) <> 0 then // ISO-8859 (e.g. iso-8859-1: => 28591)
begin
S := Copy(Charset, Length(ISO_CHARSET) + 1, Maxint);
S := Copy(S, Pos('-', S) + 1, 2);
if S = '15' then // ISO-8859-15 (Latin 9)
Result := 28605
else
Result := StrToIntDef('2859' + S, 0);
end;
end;
function GetWebBrowserHTML(WebBrowser: TWebBrowser): WideString;
var
LStream: TMemoryStream;
Stream: IStream;
LPersistStreamInit: IPersistStreamInit;
TextStream: TGpTextStream;
Charset: WideString;
Buf: WideString;
CodePage: Word;
N: Integer;
begin
Result := '';
if not Assigned(WebBrowser.Document) then Exit;
LStream := TMemoryStream.Create;
try
LPersistStreamInit := WebBrowser.Document as IPersistStreamInit;
Stream := TStreamAdapter.Create(LStream, soReference);
if Failed(LPersistStreamInit.Save(Stream, True)) then Exit;
Charset := (WebBrowser.Document as IHTMLDocument2).charset;
CodePage := GetCodePageFromHTMLCharSet(Charset);
N := LStream.Size;
SetLength(Buf, N);
TextStream := TGpTextStream.Create(LStream, tsaccRead, [], CodePage);
try
N := TextStream.Read(Buf[1], N * SizeOf(WideChar)) div SizeOf(WideChar);
SetLength(Buf, N);
Result := Buf;
finally
TextStream.Free;
end;
finally
LStream.Free();
end;
end;

Related

How to get the pointer position of beginning of second line using TFileStream in Delphi?

I'm trying to create a list of pointers to store pointers of beginning of each line using TFileStream in Delphi.
I have gone through the following link TFileStream_Methods to check all the methods. but i didn't find anything useful using which i can find the pointer value of starting position of each line.
I have tried following :
procedure TForm4.Button3Click(Sender: TObject);
var
InStream: TFileStream;
OutStream: TMemoryStream;
Writer: TStreamWriter;
Buffer: TArray<Byte>;
Encoding: TEncoding;
BOMValue: Integer;
FileName: string;
Temp: string;
TempInt: Integer;
//Buffer2: Buffer;
begin
try
//SetLength(Buffer, 8);
//InStream.Read(Buffer, Length(Buffer));
finally
//InStream.Free;
end;
try
SetLength(Buffer, 8);
//InStream.Read(Buffer, Length(Buffer));
finally
//InStream.Free;
end;
Encoding := nil;
BOMValue := TEncoding.GetBufferEncoding(Buffer, Encoding, TEncoding.ASCII);
OutStream := TMemoryStream.Create;
Writer := TStreamWriter.Create(OutStream, Encoding);
FileName := 'C:\bugs\Rnd\mainfile.cpp';
try
InStream := TFileStream.Create(FileName, fmOpenRead);
InStream.Seek(BOMValue, soCurrent);
Temp := InStream.ToString();
TempInt := InStream.InstanceSize();
OutStream.CopyFrom(InStream, 10);
InStream.Seek(10, soCurrent);
Writer.Write('abc');
OutStream.CopyFrom(InStream,60);
InStream.Free;
OutStream.SaveToFile(FileName);
finally
//InStream.Free;
Writer.Free;
OutStream.Free;
end;
end;
I am having the InStream, how can I read it character by character (even multibyte character) and can calculate the pointer of the first position of each line.
I have been trying for past 2 days but didn't have any luck. Any help would he highly appreciated.

Delphi ZLib Compress / Decompress

I've got a minor issue with decompressing using the ZLib unit in Delphi
unit uZCompression;
interface
uses
uCompression;
type
TZZipCompression = class(TInterfacedObject, ICompression)
public
function DoCompression(aContent: TArray<Byte>): TArray<Byte>;
function DoDecompression(aContent: TArray<Byte>): TArray<Byte>;
function GetWindowsBits: Integer; virtual;
end;
TZGZipCompression = class(TZZipCompression)
function GetWindowsBits: Integer; override;
end;
implementation
uses
System.ZLib, System.Classes, uMxKxUtils;
{ TZCompression }
function TZZipCompression.DoCompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TMemoryStream;
LCompressedStream: TZCompressionStream;
begin
LContentStream := ByteArrayToStream(aContent);
LOutputStream := TMemoryStream.Create;
LCompressedStream := TZCompressionStream.Create(LOutputStream, zcDefault, GetWindowsBits);
LCompressedStream.CopyFrom(LContentStream, LContentStream.Size);
LCompressedStream.Free;
Result := StreamToByteArray(LOutputStream);
LOutputStream.Free;
LContentStream.Free;
end;
function TZZipCompression.DoDecompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TMemoryStream;
LDecompressedStream: TZDecompressionStream;
begin
LContentStream := ByteArrayToStream(aContent);
LOutputStream := TMemoryStream.Create;
LDecompressedStream := TZDecompressionStream.Create(LContentStream);
LOutputStream.CopyFrom(LDecompressedStream, LDecompressedStream.Size);
LDecompressedStream.Free;
Result := StreamToByteArray(LOutputStream);
LOutputStream.Free;
LContentStream.Free;
end;
function TZZipCompression.GetWindowsBits: Integer;
begin
Result := 15;
end;
{ TZGZipCompression }
function TZGZipCompression.GetWindowsBits: Integer;
begin
Result := inherited;
Result := Result + 16;
end;
end.
This is my unit which is driven by an interface (which you don't need to know about), and data is passed in and out through a TArray variables.
I've coded it to be able to do 2 types of compression, standard zip and gzip which is determined by the windowsbits passed in to the functions.
Here are a couple of other functions being used to convert the TArray to TMemoryStream
function ByteArrayToStream(aContent: TArray<Byte>): TMemoryStream;
begin
Result := TMemoryStream.Create;
Result.Write(aContent, length(aContent)*SizeOf(aContent[0]));
Result.Position := 0;
end;
function StreamToByteArray(aStream: TMemoryStream): TArray<Byte>;
var
LStreamPos: Int64;
begin
if Assigned(aStream) then
begin
LStreamPos := aStream.Position;
aStream.Position := 0;
SetLength(Result, aStream.Size);
aStream.Read(Result, aStream.Size);
aStream.Position := LStreamPos;
end
else
SetLength(Result, 0);
end;
Now I can compress and decompress to .zip using the TZZipCompression class perfectly fine (it doesn't open up as a zip file, but it does decompress back to the original file which I can open and edit).
I can also compress to .gz using the TZGZipCompression class fine as well (interestingly I can open this gzip file perfectly well).
My issue however is that it won't decompress back from the .gz file and throws and error as soon as it hits
LOutputStream.CopyFrom(LDecompressedStream, LDecompressedStream.Size)
Funnily enough the Help file example has it as below
LOutputStream.CopyFrom(LDecompressedStream, 0)
But this doesn't work either.
Can anyone spot the issue?
Your conversion functions between TArray<Byte> and TMemoryStream are wrong, as you are not accessing the array content correctly. TArray is a dynamic array. When calling TMemoryStream.Write() and TMemoryStream.Read(), you are passing the memory address of the TArray itself, not the memory address of the data that the TArray points at. You need to reference the TArray to get the correct memory address, eg:
function ByteArrayToStream(const aContent: TArray<Byte>): TMemoryStream;
begin
Result := TMemoryStream.Create;
try
if Length(aContent) > 0 then
Result.WriteBuffer(aContent[0], Length(aContent));
Result.Position := 0;
except
Result.Free;
raise;
end;
end;
function StreamToByteArray(aStream: TMemoryStream): TArray<Byte>;
begin
if Assigned(aStream) then
begin
SetLength(Result, aStream.Size);
if Length(Result) > 0 then
Move(aStream.Memory^, Result[0], aStream.Size);
end
else
SetLength(Result, 0);
end;
Alternatively:
function ByteArrayToStream(const aContent: TArray<Byte>): TMemoryStream;
begin
Result := TMemoryStream.Create;
try
Result.WriteBuffer(PByte(aContent)^, Length(aContent));
Result.Position := 0;
except
Result.Free;
raise;
end;
end;
function StreamToByteArray(aStream: TMemoryStream): TArray<Byte>;
begin
if Assigned(aStream) then
begin
SetLength(Result, aStream.Size);
Move(aStream.Memory^, PByte(Result)^, aStream.Size);
end
else
SetLength(Result, 0);
end;
That being said, you don't need to waste memory making copies of the array data using TMemoryStream. You can use TBytesStream instead (since dynamic arrays are reference counted), eg:
function TZZipCompression.DoCompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TBytesStream;
LCompressedStream: TZCompressionStream;
begin
LContentStream := TBytesStream.Create(aContent);
try
LOutputStream := TBytesStream.Create(nil);
try
LCompressedStream := TZCompressionStream.Create(LOutputStream, zcDefault, GetWindowsBits);
try
LCompressedStream.CopyFrom(LContentStream, 0);
finally
LCompressedStream.Free;
end;
Result := Copy(LOutputStream.Bytes, 0, LOutputStream.Size);
finally
LOutputStream.Free;
end;
finally
LContentStream.Free;
end;
end;
function TZZipCompression.DoDecompression(aContent: TArray<Byte>): TArray<Byte>;
var
LContentStream, LOutputStream: TBytesStream;
LDecompressedStream: TZDecompressionStream;
begin
LContentStream := TBytesStream.Create(aContent);
try
LOutputStream := TBytesStream.Create(nil);
try
LDecompressedStream := TZDecompressionStream.Create(LContentStream, GetWindowsBits);
try
LOutputStream.CopyFrom(LDecompressedStream, 0);
finally
LDecompressedStream.Free;
end;
Result := Copy(LOutputStream.Bytes, 0, LOutputStream.Size);
finally
LOutputStream.Free;
end;
finally
LContentStream.Free;
end;
end;

How to encode strings with EncdDec library

I have this basic code that should encode a string and then get it back. However, the decoded text is garbage.
procedure TForm5.Button2Click(Sender: TObject);
VAR s1, s2, s3: String;
i: Integer;
begin
for i:= 1 to 200
DO s1:= s1+ char(Random(255));
s1:= EncdDecd.EncodeString(s1);
s3:= EncdDecd.DecodeString(s2);
if s1= s3
then Caption:= 'Equal'
else Caption:= 'Not equal';
end;
Update:
It works if I do char(Random(128)) instead of 255!
The problem is here, in the Soap.EncdDecd unit:
function EncodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input);
try
OutStr := TStringStream.Create('');
try
EncodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
This code has not been updated for Unicode. The use of TStringStream for InStr without specifying an encoding is the problem. With no encoding specified, ANSI is used to decode to a byte array. And so only characters in the local ANSI code page are decoded correctly.
The same mistake is made in the other direction in DecodeString.
You can fix this readily enough by creating variants that specify a full Unicode encoding. For example:
function EncodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input, TEncoding.UTF8);
try
OutStr := TStringStream.Create('');
try
EncodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
function DecodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input);
try
OutStr := TStringStream.Create('', TEncoding.UTF8);
try
DecodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
It doesn't matter which encoding you specify so long as it is a full Unicode encoding, and you use the same encoding in both directions!
Clearly Embarcadero should be encouraged to make this change to their code.
This program demonstrates that the fix works:
{$APPTYPE CONSOLE}
uses
System.SysUtils, System.Classes, Soap.EncdDecd;
function EncodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input, TEncoding.UTF8);
try
OutStr := TStringStream.Create('');
try
EncodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
function DecodeString(const Input: string): string;
var
InStr, OutStr: TStringStream;
begin
InStr := TStringStream.Create(Input);
try
OutStr := TStringStream.Create('', TEncoding.UTF8);
try
DecodeStream(InStr, OutStr);
Result := OutStr.DataString;
finally
OutStr.Free;
end;
finally
InStr.Free;
end;
end;
const
N = 256;
var
i: Integer;
s1, s2: string;
begin
SetLength(s1, N);
for i := 1 to N do
s1[i] := Chr(i-1);
s2 := Soap.EncdDecd.EncodeString(s1);
s2 := Soap.EncdDecd.DecodeString(s2);
Writeln(s1=s2);
s2 := EncodeString(s1);
s2 := DecodeString(s2);
Writeln(s1=s2);
end.
Output:
FALSE
TRUE
Quick fix:
ANSI is enough for me since the text resulted after encoding must be as short as possible (easy to send via email). So, I put my ANSI string into a stream and encoded/decoded the stream. It worked!
Jesus. Some documentation (at least a single comment line) would have been nice!

Unicode problems with Base64 strings and Streams

I have been working on a project in Lazarus and have decided to move it to Delphi XE for the time being (due to some limitations).
A brief overview of what is going on:
At runtime I am loading external files and adding them to streams. The streams belong to several different classes that descend from one main object (TObject). These classes are added to a TList from the main object, basically each class has its own stream property and the class is child to the main object.
In this main object I have a save and load procedure:
When saving the object it also saves all the stream data from the other classes to file by using string to stream. The output string here must be base64 encoded as I am saving to XML.
When opening the file, the idea is to decode the base64 string and move it back into the streams just as if it were the original file before it was base64 encoded.
In Lazarus it works, and here is the important code (note, some of it was not written by me).
const
Keys64 = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/';
function Encode64String(S: string): string;
function Decode64String(S: string): string;
function Encode64StringToStream(const Input: TStream; var Output: string): Boolean;
procedure Decode64StringToStream(const Input: string; Output: TStream);
procedure StringToStream(Stream: TStream; const S: string);
function StreamToString(MS: TMemoryStream): string;
implementation
function Encode64String(S: string): string;
var
i: Integer;
a: Integer;
x: Integer;
b: Integer;
begin
Result := '';
a := 0;
b := 0;
for i := 1 to Length(s) do
begin
x := Ord(s[i]);
b := b * 256 + x;
a := a + 8;
while a >= 6 do
begin
a := a - 6;
x := b div (1 shl a);
b := b mod (1 shl a);
Result := Result + Keys64[x + 1];
end;
end;
if a > 0 then
begin
x := b shl (6 - a);
Result := Result + Keys64[x + 1];
end;
end;
function Decode64String(S: string): string;
var
i: Integer;
a: Integer;
x: Integer;
b: Integer;
begin
Result := '';
a := 0;
b := 0;
for i := 1 to Length(s) do
begin
x := Pos(s[i], Keys64) - 1;
if x >= 0 then
begin
b := b * 64 + x;
a := a + 6;
if a >= 8 then
begin
a := a - 8;
x := b shr a;
b := b mod (1 shl a);
x := x mod 256;
Result := Result + chr(x);
end;
end
else
Exit;
end;
end;
function Encode64StringToStream(const Input: TStream; var Output: string): Boolean;
var
MS: TMemoryStream;
begin
Result := False;
MS := TMemoryStream.Create;
try
Input.Seek(0, soFromBeginning);
MS.CopyFrom(Input, Input.Size);
MS.Seek(0, soFromBeginning);
Output := Encode64String(StreamToString(MS));
finally
MS.Free;
end;
Result := True;
end;
procedure Decode64StringToStream(const Input: string; Output: TStream);
var
MS: TMemoryStream;
begin
try
MS := TMemoryStream.Create;
try
StringToStream(MS, Decode64String(Input));
MS.Seek(0, soFromBeginning);
Output.CopyFrom(MS, MS.Size);
Output.Position := 0;
finally
MS.Free;
end;
except on E: Exception do
raise Exception.Create('stream decode error - ' + E.Message);
end;
end;
procedure StringToStream(Stream: TStream; const S: string);
begin
Stream.Write(Pointer(S)^, Length(S));
end;
function StreamToString(MS: TMemoryStream): string;
begin
SetString(Result, PChar(MS.Memory), MS.Size div SizeOf(Char));
end;
I am 99% sure the problem here is going to be unicode related. It's a shame because I believe Lazarus/Freepascal has always been unicode but not Delphi and so uses different string types making it almost impossible for the less professional users like myself to solve!
To be honest I think all the code above is a bit of a mess, and it feels like I am just trying to guess what to change the strings to without really knowing what I am doing.
My first thought was to change everything from String to AnsiString. This nearly worked one time but when trying to use Decode64StringToStream I got zero data back. Other times the data was not properly saving as base64 encoded format, and sometimes I even got errors like TStream.Seek not implemented or something.
PS, I have read the guides and there is plenty around such as the whitepapers etc on how to migrate old Delphi projects to newer unicode versions and to be honest I am still at a loss with it. I thought replacing string to AnsiString would have been enough, but it seems it isn't.
Any tips, pointers or general advice or clues would be greatly appreciated thanks.
I think what you want to do is:
Convert the Unicode string to UTF-8 encoding. This is often the most space efficient format for Unicode text.
Encode the string using base64.
Then to decode you just reverse the steps.
The code looks like this:
function Encode(const Input: string): AnsiString;
var
utf8: UTF8String;
begin
utf8 := UTF8String(Input);
Result := EncdDecd.EncodeBase64(PAnsiChar(utf8), Length(utf8));
end;
function Decode(const Input: AnsiString): string;
var
bytes: TBytes;
utf8: UTF8String;
begin
bytes := EncdDecd.DecodeBase64(Input);
SetLength(utf8, Length(bytes));
Move(Pointer(bytes)^, Pointer(utf8)^, Length(bytes));
Result := string(utf8);
end;

How to determine Delphi Application Version

Want to obtain Delphi Application build number and post into title bar
Here is how I do it. I put this in almost all of my small utilities:
procedure GetBuildInfo(var V1, V2, V3, V4: word);
var
VerInfoSize, VerValueSize, Dummy: DWORD;
VerInfo: Pointer;
VerValue: PVSFixedFileInfo;
begin
VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
if VerInfoSize > 0 then
begin
GetMem(VerInfo, VerInfoSize);
try
if GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo) then
begin
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
end;
finally
FreeMem(VerInfo, VerInfoSize);
end;
end;
end;
function GetBuildInfoAsString: string;
var
V1, V2, V3, V4: word;
begin
GetBuildInfo(V1, V2, V3, V4);
Result := IntToStr(V1) + '.' + IntToStr(V2) + '.' +
IntToStr(V3) + '.' + IntToStr(V4);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Caption := Form1.Caption + ' - v' + GetBuildInfoAsString;
end;
I most strongly recommend not to use GetFileVersion when you want to know the version of the executable that is currently running! I have two pretty good reasons to do this:
The executable may be unaccessible (disconnected drive/share), or changed (.exe renamed to .bak and replaced by a new .exe without the running process being stopped).
The version data you're trying to read has actually already been loaded into memory, and is available to you by loading this resource, which is always better than to perform extra (relatively slow) disk operations.
To load the version resource in Delphi I use code like this:
uses Windows,Classes,SysUtils;
var
verblock:PVSFIXEDFILEINFO;
versionMS,versionLS:cardinal;
verlen:cardinal;
rs:TResourceStream;
m:TMemoryStream;
p:pointer;
s:cardinal;
begin
m:=TMemoryStream.Create;
try
rs:=TResourceStream.CreateFromID(HInstance,1,RT_VERSION);
try
m.CopyFrom(rs,rs.Size);
finally
rs.Free;
end;
m.Position:=0;
if VerQueryValue(m.Memory,'\',pointer(verblock),verlen) then
begin
VersionMS:=verblock.dwFileVersionMS;
VersionLS:=verblock.dwFileVersionLS;
AppVersionString:=Application.Title+' '+
IntToStr(versionMS shr 16)+'.'+
IntToStr(versionMS and $FFFF)+'.'+
IntToStr(VersionLS shr 16)+'.'+
IntToStr(VersionLS and $FFFF);
end;
if VerQueryValue(m.Memory,PChar('\\StringFileInfo\\'+
IntToHex(GetThreadLocale,4)+IntToHex(GetACP,4)+'\\FileDescription'),p,s) or
VerQueryValue(m.Memory,'\\StringFileInfo\\040904E4\\FileDescription',p,s) then //en-us
AppVersionString:=PChar(p)+' '+AppVersionString;
finally
m.Free;
end;
end;
Thanks to the posts above, I made my own library for this purpose.
I believe that it is a little bit more correct than all other solutions here, so I share it - feel free to reuse it...
unit KkVersion;
interface
function FileDescription: String;
function LegalCopyright: String;
function DateOfRelease: String; // Proprietary
function ProductVersion: String;
function FileVersion: String;
implementation
uses
Winapi.Windows, System.SysUtils, System.Classes, Math;
(*
function GetHeader(out AHdr: TVSFixedFileInfo): Boolean;
var
BFixedFileInfo: PVSFixedFileInfo;
RM: TMemoryStream;
RS: TResourceStream;
BL: Cardinal;
begin
Result := False;
RM := TMemoryStream.Create;
try
RS := TResourceStream.CreateFromID(HInstance, 1, RT_VERSION);
try
RM.CopyFrom(RS, RS.Size);
finally
FreeAndNil(RS);
end;
// Extract header
if not VerQueryValue(RM.Memory, '\\', Pointer(BFixedFileInfo), BL) then
Exit;
// Prepare result
CopyMemory(#AHdr, BFixedFileInfo, Math.Min(sizeof(AHdr), BL));
Result := True;
finally
FreeAndNil(RM);
end;
end;
*)
function GetVersionInfo(AIdent: String): String;
type
TLang = packed record
Lng, Page: WORD;
end;
TLangs = array [0 .. 10000] of TLang;
PLangs = ^TLangs;
var
BLngs: PLangs;
BLngsCnt: Cardinal;
BLangId: String;
RM: TMemoryStream;
RS: TResourceStream;
BP: PChar;
BL: Cardinal;
BId: String;
begin
// Assume error
Result := '';
RM := TMemoryStream.Create;
try
// Load the version resource into memory
RS := TResourceStream.CreateFromID(HInstance, 1, RT_VERSION);
try
RM.CopyFrom(RS, RS.Size);
finally
FreeAndNil(RS);
end;
// Extract the translations list
if not VerQueryValue(RM.Memory, '\\VarFileInfo\\Translation', Pointer(BLngs), BL) then
Exit; // Failed to parse the translations table
BLngsCnt := BL div sizeof(TLang);
if BLngsCnt <= 0 then
Exit; // No translations available
// Use the first translation from the table (in most cases will be OK)
with BLngs[0] do
BLangId := IntToHex(Lng, 4) + IntToHex(Page, 4);
// Extract field by parameter
BId := '\\StringFileInfo\\' + BLangId + '\\' + AIdent;
if not VerQueryValue(RM.Memory, PChar(BId), Pointer(BP), BL) then
Exit; // No such field
// Prepare result
Result := BP;
finally
FreeAndNil(RM);
end;
end;
function FileDescription: String;
begin
Result := GetVersionInfo('FileDescription');
end;
function LegalCopyright: String;
begin
Result := GetVersionInfo('LegalCopyright');
end;
function DateOfRelease: String;
begin
Result := GetVersionInfo('DateOfRelease');
end;
function ProductVersion: String;
begin
Result := GetVersionInfo('ProductVersion');
end;
function FileVersion: String;
begin
Result := GetVersionInfo('FileVersion');
end;
end.
Pass the full file name of your EXE to this function, and it will return a string like:
2.1.5.9, or whatever your version # is.
function GetFileVersion(exeName : string): string;
const
c_StringInfo = 'StringFileInfo\040904E4\FileVersion';
var
n, Len : cardinal;
Buf, Value : PChar;
begin
Result := '';
n := GetFileVersionInfoSize(PChar(exeName),n);
if n > 0 then begin
Buf := AllocMem(n);
try
GetFileVersionInfo(PChar(exeName),0,n,Buf);
if VerQueryValue(Buf,PChar(c_StringInfo),Pointer(Value),Len) then begin
Result := Trim(Value);
end;
finally
FreeMem(Buf,n);
end;
end;
end;
After defining that, you can use it to set your form's caption like so:
procedure TForm1.FormShow(Sender: TObject);
begin
//ParamStr(0) is the full path and file name of the current application
Form1.Caption := Form1.Caption + ' version ' + GetFileVersion(ParamStr(0));
end;
We do this for all our apps but we use a Raize component RzVersioninfo.
works quite well just need to use the following code
on form create
Caption := RzVersioninfo1.filedescripion + ': ' + RzVersionInfo1.FileVersion;
obviously if you don't want any of the other components from raize use one of the options above as there is a cost to the raize components.
From http://www.martinstoeckli.ch/delphi/delphi.html#AppVersion
With this function you can get the version of a file, which contains a
version resource. This way you can display the version number of your
application in an information dialog. To include a version resource to
your Delphi application, set the "Versioninfo" in the project options.
My code:
uses unit Winapi.Windows;
function GetModuleVersion(Instance: THandle; out iMajor, iMinor, iRelease, iBuild: Integer): Boolean;
var
fileInformation: PVSFIXEDFILEINFO;
verlen: Cardinal;
rs: TResourceStream;
m: TMemoryStream;
begin
result := false;
m := TMemoryStream.Create;
try
try
rs := TResourceStream.CreateFromID(Instance, 1, RT_VERSION);
try
m.CopyFrom(rs, rs.Size);
finally
rs.Free;
end;
except
exit;
end;
m.Position:=0;
if not VerQueryValue(m.Memory, '\', Pointer(fileInformation), verlen) then
begin
iMajor := 0;
iMinor := 0;
iRelease := 0;
iBuild := 0;
Exit;
end;
iMajor := fileInformation.dwFileVersionMS shr 16;
iMinor := fileInformation.dwFileVersionMS and $FFFF;
iRelease := fileInformation.dwFileVersionLS shr 16;
iBuild := fileInformation.dwFileVersionLS and $FFFF;
finally
m.Free;
end;
Result := True;
end;
Usage:
if GetModuleVersion(HInstance, iMajor, iMinor, iRelease, iBuild) then
ProgramVersion := inttostr(iMajor)+'.'+inttostr(iMinor)+'.'+inttostr(iRelease)+'.'+inttostr(iBuild);

Resources