pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

With LCLPlatformDef fix

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7316 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
2020-01-24 15:11:39 +00:00
parent 9e2424d40d
commit 7285408764
17 changed files with 6125 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
components/splashabout/exampleapp/project1.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

92
components/splashabout/exampleapp/project1.lpi Normal file
View File

@ -0,0 +1,92 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="project1"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<UseVersionInfo Value="True"/>
<AutoIncrementBuild Value="True"/>
<MajorVersionNr Value="1"/>
<BuildNr Value="1"/>
<StringTable ProductVersion="Product"/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="X:\Looks"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="1">
<Mode0 Name="default"/>
</Modes>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="splashabout"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="E:\PASCAL64\lazarus\components\splashabout\exampleapp\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
components/splashabout/exampleapp/project1.lpr Normal file
View File

@ -0,0 +1,21 @@
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

75
components/splashabout/exampleapp/project1.lps Normal file
View File

@ -0,0 +1,75 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectSession>
<PathDelim Value="\"/>
<Version Value="11"/>
<BuildModes Active="Default"/>
<Units Count="4">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UsageCount Value="64"/>
<Loaded Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="2"/>
<CursorPos X="32" Y="27"/>
<UsageCount Value="64"/>
<Loaded Value="True"/>
<LoadedDesigner Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\usplashabout.pas"/>
<EditorIndex Value="1"/>
<TopLine Value="670"/>
<CursorPos Y="672"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="..\..\..\lcl\lresources.pp"/>
<UnitName Value="LResources"/>
<TopLine Value="5249"/>
<CursorPos Y="5268"/>
<UsageCount Value="7"/>
</Unit3>
</Units>
<JumpHistory Count="6" HistoryIndex="5">
<Position1>
<Filename Value="..\usplashabout.pas"/>
<Caret Line="141" Column="29" TopLine="115"/>
</Position1>
<Position2>
<Filename Value="..\usplashabout.pas"/>
<Caret Line="664" Column="64" TopLine="651"/>
</Position2>
<Position3>
<Filename Value="..\usplashabout.pas"/>
<Caret Line="186" Column="43" TopLine="172"/>
</Position3>
<Position4>
<Filename Value="..\usplashabout.pas"/>
<Caret Line="185" Column="42" TopLine="166"/>
</Position4>
<Position5>
<Filename Value="..\usplashabout.pas"/>
<Caret Line="191" TopLine="163"/>
</Position5>
<Position6>
<Filename Value="..\usplashabout.pas"/>
<Caret Line="660" Column="49" TopLine="643"/>
</Position6>
</JumpHistory>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0" ActiveMode="default"/>
</RunParams>
</ProjectSession>
</CONFIG>

BIN
components/splashabout/exampleapp/project1.res Normal file
View File

Binary file not shown.

BIN
components/splashabout/exampleapp/ski.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 56 KiB

BIN
components/splashabout/exampleapp/splash.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 21 KiB

54
components/splashabout/exampleapp/unit1.lfm Normal file
View File

@ -0,0 +1,54 @@
object Form1: TForm1
Left = 368
Height = 94
Top = 200
Width = 184
Caption = 'Form Caption'
ClientHeight = 94
ClientWidth = 184
OnCreate = FormCreate
Position = poDesktopCenter
LCLVersion = '1.2.0.2'
object BitBtn1: TBitBtn
Left = 16
Height = 30
Top = 8
Width = 75
Caption = 'About'
OnClick = BitBtn1Click
TabOrder = 0
end
object BitBtn2: TBitBtn
Left = 96
Height = 30
Top = 8
Width = 75
Caption = 'Splash'
OnClick = BitBtn2Click
TabOrder = 1
end
object BitBtn3: TBitBtn
Left = 56
Height = 30
Top = 48
Width = 75
DefaultCaption = True
Kind = bkClose
ModalResult = 11
TabOrder = 2
end
object SplashAbout1: TSplashAbout
OptionalIconFilePath = 'ski.ico'
BackGroundImageFilePath = 'splash.jpg'
MaskType = saRoundedRect
LicenseFile = saGPL
CreditText = 'programmed by Gordon'
SupportContact = 'minesadorada@charcodelvalle.com'
Author = 'Gordon Bamber'
UserTitle = 'SplashAbout Demo Application'
ShowDescription = False
Description = 'An example application to demonstrate the SplashAbout lazarus visual component.'
left = 30
top = 58
end
end

54
components/splashabout/exampleapp/unit1.pas Normal file
View File

@ -0,0 +1,54 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, usplashabout, Forms, Controls, Graphics, Dialogs,
Buttons, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
SplashAbout1: TSplashAbout;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
SplashAbout1.ShowAbout;
end;
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
SplashAbout1.ShowSplash;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SplashAbout1.ShowSplash;
end;
end.

72
components/splashabout/license.lrs Normal file
View File

@ -0,0 +1,72 @@
LazarusResources.Add('gpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This source'
+' is free software; you can redistribute it and/or modify it under'#13#10' '
+'the terms of the GNU General Public License as published by the Free'#13#10
+' Software Foundation; either version 2 of the License, or (at your option)'
+#13#10' any later version.'#13#10#13#10' This code is distributed in the h'
+'ope that it will be useful, but WITHOUT ANY'#13#10' WARRANTY; without even'
+' the implied warranty of MERCHANTABILITY or FITNESS'#13#10' FOR A PARTICUL'
+'AR PURPOSE. See the GNU General Public License for more'#13#10' details.'
+#13#10#13#10' A copy of the GNU General Public License is available on the '
+'World Wide Web'#13#10' at <http://www.gnu.org/copyleft/gpl.html>. You can '
+'also obtain it by writing'#13#10' to the Free Software Foundation, Inc., 5'
+'9 Temple Place - Suite 330, Boston,'#13#10' MA 02111-1307, USA.'
]);
LazarusResources.Add('lgpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This librar'
+'y is free software; you can redistribute it and/or modify it'#13#10' under'
+' the terms of the GNU Library General Public License as published by'#13#10
+' the Free Software Foundation; either version 2 of the License, or (at you'
+'r'#13#10' option) any later version.'#13#10#13#10' This program is distri'
+'buted in the hope that it will be useful, but WITHOUT'#13#10' ANY WARRANTY'
+'; without even the implied warranty of MERCHANTABILITY or'#13#10' FITNESS '
+'FOR A PARTICULAR PURPOSE. See the GNU Library General Public License'#13#10
+' for more details.'#13#10#13#10' You should have received a copy of the G'
+'NU Library General Public License'#13#10' along with this library; if not,'
+' write to the Free Software Foundation,'#13#10' Inc., 59 Temple Place - Su'
+'ite 330, Boston, MA 02111-1307, USA.'
]);
LazarusResources.Add('mit.txt','TXT',[
' Copyright (c) <year> <copyright holders>'#13#10#13#10' Permission is here'
+'by granted, free of charge, to any person obtaining a copy'#13#10' of this'
+' software and associated documentation files (the "Software"), to'#13#10' '
+'deal in the Software without restriction, including without limitation the'
+#13#10' rights to use, copy, modify, merge, publish, distribute, sublicense'
+', and/or'#13#10' sell copies of the Software, and to permit persons to who'
+'m the Software is'#13#10' furnished to do so, subject to the following con'
+'ditions:'#13#10#13#10' The above copyright notice and this permission noti'
+'ce shall be included in'#13#10' all copies or substantial portions of the '
+'Software.'#13#10#13#10' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY'
+' OF ANY KIND, EXPRESS OR'#13#10' IMPLIED, INCLUDING BUT NOT LIMITED TO THE'
+' WARRANTIES OF MERCHANTABILITY,'#13#10' FITNESS FOR A PARTICULAR PURPOSE A'
+'ND NONINFRINGEMENT. IN NO EVENT SHALL THE'#13#10' AUTHORS OR COPYRIGHT HOL'
+'DERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER'#13#10' LIABILITY, WHETHER '
+'IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING'#13#10' FROM, OUT OF '
+'OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS'#13#10' IN'
+' THE SOFTWARE.'
]);
LazarusResources.Add('modifiedgpl.txt','TXT',[
' Copyright (C) <year> <name of author> <contact>'#13#10#13#10' This librar'
+'y is free software; you can redistribute it and/or modify it'#13#10' under'
+' the terms of the GNU Library General Public License as published by'#13#10
+' the Free Software Foundation; either version 2 of the License, or (at you'
+'r'#13#10' option) any later version with the following modification:'#13#10
+#13#10' As a special exception, the copyright holders of this library give '
+'you'#13#10' permission to link this library with independent modules to pr'
+'oduce an'#13#10' executable, regardless of the license terms of these inde'
+'pendent modules,and'#13#10' to copy and distribute the resulting executabl'
+'e under terms of your choice,'#13#10' provided that you also meet, for eac'
+'h linked independent module, the terms'#13#10' and conditions of the licen'
+'se of that module. An independent module is a'#13#10' module which is not '
+'derived from or based on this library. If you modify'#13#10' this library,'
+' you may extend this exception to your version of the library,'#13#10' but'
+' you are not obligated to do so. If you do not wish to do so, delete this'
+#13#10' exception statement from your version.'#13#10#13#10' This program '
+'is distributed in the hope that it will be useful, but WITHOUT'#13#10' ANY'
+' WARRANTY; without even the implied warranty of MERCHANTABILITY or'#13#10' '
+' FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public Licen'
+'se'#13#10' for more details.'#13#10#13#10' You should have received a cop'
+'y of the GNU Library General Public License'#13#10' along with this librar'
+'y; if not, write to the Free Software Foundation,'#13#10' Inc., 59 Temple '
+'Place - Suite 330, Boston, MA 02111-1307, USA.'
]);

4625
components/splashabout/masks.lrs Normal file
View File

File diff suppressed because it is too large Load Diff

35
components/splashabout/readme.txt Normal file
View File

@ -0,0 +1,35 @@
SplashAbout component for Lazarus
minesadorada@charcodelvalle.com
============================
Installation
========
Make a new folder 'splashabout' in your lazarus/components folder
Copy the contents of the zip file into it
In Lazarus, choose the menu 'Package/Install/Uninstall Packages'
From the right-hand column, select 'splashabout 1.0' and click 'Install selection'
Lazarus will ask you whether to 'recompile the IDE' - answer 'yes'
When all is done, click the 'Additional' component palette to see the SplashAbout component.
Use
===
Add the component to your form (SplashAbout1)
To show a splash screen:
In the FormCreate event, use this code:
procedure TForm1.FormCreate(Sender: TObject);
begin
SplashAbout1.ShowSplash;
end;
To show the 'About' dialog, use this code:
procedure TForm1.Button1Click(Sender: TObject);
begin
SplashAbout1.ShowAbout;
end;
Tweaking
=======
See the 'testapp' example project to experiment

50
components/splashabout/splashabout.lpk Normal file
View File

@ -0,0 +1,50 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="splashabout"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Gordon Bamber (minesadorada@charcodelvalle.com)"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="D:\lazarusccr\components\poweredby\latest_stable\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
</CompilerOptions>
<Description Value="Two methods: SplashAbout1.ShowSplash (in form1.create method) and SplashAbout1.ShowAbout.
Windows are created on-the-fly and destroyed on close.
"/>
<License Value="LGPL
Use and abuse as you will."/>
<Version Major="1" Minor="2" Build="1"/>
<Files Count="2">
<Item1>
<Filename Value="usplashabout.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="usplashabout"/>
</Item1>
<Item2>
<Filename Value="uversion.pas"/>
<UnitName Value="uversion"/>
</Item2>
</Files>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

22
components/splashabout/splashabout.pas Normal file
View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit splashabout;
{$warn 5023 off : no warning about unused units}
interface
uses
usplashabout, uversion, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('usplashabout', @usplashabout.Register);
end;
initialization
RegisterPackage('splashabout', @Register);
end.

11
components/splashabout/splashabout_ico.lrs Normal file
View File

@ -0,0 +1,11 @@
LazarusResources.Add('tsplashabout','PNG',[
#137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0
+#0#0',tEXtCreation Time'#0'Mon 19 May 2014 15:38:36 -0000'#5'v'#139'Z'#0#0#0
+#7'tIME'#7#222#5#19#15#11#29#229#2'R'#209#0#0#0#9'pHYs'#0#0#14#195#0#0#14#195
+#1#199'o'#168'd'#0#0#0#4'gAMA'#0#0#177#143#11#252'a'#5#0#0#0'fIDATx'#218'c`'
+#160'1`'#4#17#13#13#13#255'ia8'#208'\F'#22#24#199#193#161#158#170#134#31'8'
+#208#8#166#153'h'#23'8'#16#192#130'`'#30#164#137#5'4'#247#193#168#5#163#22
+#140'Z@'#207#162#226#192#129#3#180#182'kp'#0#146#235#13'F2'#13'''E'#31'I'#134
+#163#211'T'#7'$'#27'LJ2%'#203#213#248#194#242'?'#137#234#7#6#0#0'C'#144#18'#'
+#137#149'e'#21#0#0#0#0'IEND'#174'B`'#130
]);

719
components/splashabout/usplashabout.pas Normal file
View File

@ -0,0 +1,719 @@
unit usplashabout;
{$mode objfpc}{$H+}
interface
{
Credits
=======
uversion.pas by Mike Thompson - mike.cornflake@gmail.com
originally as VersionSupport.pas
See uversion.pas header for more details
========================================================
SplashAbout component by minesadorada@charcodelvalle.com
========================================================
Licence: Modified GPL licence. Free to use and/or incorporate in your code.
Purpose
=======
Constructs a Splash screen and/or About form with as little effort and resources as possible :)
The windows and controls are created and destroyed on-the-fly to reduce application size
For use in any Lazarus 1.x/FPC 2.x application
Files needed to install component
=================================================
uspalshabout.lpk usplashabout.pas,uversion.pas
Optional Files (in the same folder as your application)
=======================================================
Optional: gpl.txt, lgpl.txt,modifiedgpl.txt,mit.txt
Optional: <splashgraphic>.(bmp/jpg/gif)
Optional: <splashicon>.ico
Optional: <maskgraphic>.bmp
How to use in your project (see TestApp project)
================================================
Use the Property Editor to set propertes as normal
or override them as below before calling ShowSplash or ShowAbout
// If SplashAbout1.DelaySeconds set to zero, then Splash will close only when your application becomes idle
SplashAbout1.UserTitle:='My Superb App'; // Will override property only of TitleStyle is set to saUserTitle
SplashAbout1.OptionalIconFilePath:='myicon.ico'; // OPTIONAL. If TitleStyle is saUserTitle then overrides default
SplashAbout1.BackGroundImageFilePath:='splash.jpg'; // OPTIONAL. Default is no Background Image. Optimal size=320 x 240
SplashAbout1.MaskImageFilePath:='roundedrect.bmp'; // OPTIONAL.
// Makes a shaped splash form. Optimum source: .BMP image, 2-bit color depth or more, black area=invisible, white area=visible. Size >= 320 x 240
// If a jpg file is specified by mistake, it will be converted to a (large filesize 24bbp!) .bmp and saved to disk on first run.
SplashAbout1.LicenseFile ; // Default is for Licence button to be absent on ShowAbout method
SplashAbout1.CreditText:='Freeware by minesadorada'; // Default is no text
SplashAbout1.Author:='Mines A. Dorada'; // OPTIONAL. Default is boilerplate text in LicenseFile Path
SplashAbout1.SupportContact:='minesadorada@charcodelvalle.com'; // OPTIONAL. Default is boilerplate text in LicenseFile Path
SplashAbout1.ShowSplash;
=============================
EXAMPLE USE in Help/About
=========================
SplashAbout1.ShowAbout;
}
uses
Classes, SysUtils, Forms, Controls, Graphics, Buttons,
LCLIntf, LCLType, LResources,
ExtCtrls, StdCtrls, StrUtils, Dialogs, uversion,uPoweredby,PropEdits;
type
tFormType = (fSplash, fAbout);
tLicenseFile = (saNone, saGPL, saLGPL, saMIT, saModifiedGPL, saUserFile);
tCreateType = (saUserTitle, saForm, saApplication);
tmasktype = (saNomask, saRoundedRect, saBigCog, saBigFlower, saBigSplash, saUserImage);
const
C_DEFAULTSPLASHWIDTH = 320;
C_DEFAULTSPLASHHEIGHT = 240;
C_DEFAULTSPLASHHEIGHT_LINUX = 280;
C_DEFAULTLICENSEFORMWIDTH = 500;
C_DEFAULTLICENSEFORMWIDTH_LINUX = 600;
C_DEFAULTLICENSEFORMHEIGHT = 400;
C_DEFAULTLICENSEFORMHEIGHT_LINUX = 450;
type
TSplashAbout = class(TComponent)
private
fSplashForm: TForm;
fFormType: tFormType;
fIcon: TIcon;
fDelaySeconds: integer;
fTitleString: string;
fBackGroundColor: TColor;
fIconFilePath, fBackGroundImageFilePath, fMaskImageFilePath: string;
fVersionInfoString: string;
fAppVersionString: string;
fLicenseFile: tLicenseFile;
fLicenseTypeString: string;
fCreditString: string;
fAuthorString: string;
fSupportContactString: string;
fCloseOnIdle: boolean;
szLicenseFile: string;
fCreateType: tCreateType;
fShowDescription: boolean;
fDescription: string;
// Initialised in Constructor
fFormTitleString: string;
fFormIcon: TIcon;
fMaskType: tMaskType;
fPoweredBy:TPoweredBy;
procedure CloseForm(Sender: TObject);
procedure ShowForm;
procedure ShowLicense(Sender: TObject);
function MakeBMPfromJPG(var JPGFilePath: string): boolean;
procedure ApplicationOnIdle(Sender: TObject; var {%H-}Done: boolean);
protected
public
// Use anything from here..
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ShowSplash;
procedure ShowAbout;
published
property PoweredBy:TPoweredBy read fPoweredBy write fPoweredBy;
property DelaySeconds: integer read fDelaySeconds write fDelaySeconds default 2;
property BackGroundColor: TColor read fBackGroundColor
write fBackGroundColor default clSkyBlue;
property OptionalIconFilePath: string read fIconFilePath write fIconFilePath;
property BackGroundImageFilePath: string
read fBackGroundImageFilePath write fBackGroundImageFilePath;
property MaskImageFilePath: string read fMaskImageFilePath write fMaskImageFilePath;
property MaskType: tMaskType read fMaskType write fMaskType default saNomask;
property LicenseFile: tLicenseFile
read fLicenseFile write fLicenseFile default saNone;
// property LicenseName: string read fLicenseTypeString write fLicenseTypeString;
property CreditText: string read fCreditString write fCreditString;
property SupportContact: string read fSupportContactString
write fSupportContactString;
property Author: string read fAuthorString write fAuthorString;
property TitleStyle: TCreateType read fCreateType write fCreateType default
saUserTitle;
property UserTitle: string read fTitleString write fTitleString;
property ShowDescription: boolean read fShowDescription write fShowDescription;
property Description: string read fDescription write fDescription;
end;
procedure Register;
implementation
procedure Register;
begin
{$I splashabout_ico.lrs}
RegisterComponents('Additional', [TSplashAbout]);
RegisterPropertyEditor(TypeInfo(TPoweredBy),
TSplashAbout, 'PoweredBy', TClassPropertyEditor);end;
destructor TSplashAbout.Destroy;
begin
Application.RemoveOnIdleHandler(@ApplicationOnIdle);
inherited Destroy;
end;
constructor TSplashAbout.Create(AOwner: TComponent);
// Initialise private vars
var
Frm: TForm;
begin
inherited Create(AOwner);
// Use tPoweredBy as a subcomponent
// Register a TClassPropertyEditor in order to display it correctly
fPoweredBy := TPoweredBy.Create(Self);
fPoweredBy.SetSubComponent(true); // Tell the IDE to store the modified properties
fPoweredBy.Name:='PoweredBy';
// From main form [Create(Self)]
if (AOwner is TForm) then
begin
Frm := AOwner as TForm;
fFormTitleString := Frm.Caption;
fFormIcon := Frm.Icon;
end;
DelaySeconds := 2;
BackGroundColor := clSkyBlue;
fAppVersionString := LineEnding;
// Use uversion unit public methods to populate (Credit: Mike Thompson)
if (GetFileVersion <> 'No build information available') then
fAppVersionString += 'Version ' + GetFileVersion + LineEnding + LineEnding;
fVersionInfoString := fAppVersionString + 'Made with: ' + GetLCLVersion;
fVersionInfoString += ' and ' + GetCompilerInfo + LineEnding;
fVersionInfoString += 'For: ' + GetTargetInfo + ' (' + GetWidgetSet + ')' + LineEnding;
fVersionInfoString += 'Last Compiled: ' + GetCompiledDate;
// Optional property values
fBackGroundImageFilePath := '';
fMaskImageFilePath := '';
fTitleString := 'My Application';
fCloseOnIdle := False;
end;
procedure TSplashAbout.ApplicationOnIdle(Sender: TObject; var Done: boolean);
begin
if fSplashForm = nil then
exit;
if fCloseOnIdle then
if fSplashForm.Visible then
begin
fSplashForm.ModalResult := mrClose;
Done := True;
end;
end;
function TSplashAbout.MakeBMPfromJPG(var JPGFilePath: string): boolean;
// The MaskImageFilePath has to be a BMP image file (ideally 2bbp).
// If the developer sets the property to a JPG image file, then this routine
// will convert it to BMP and save it to disk. The resulting BMP file is likely
// to be a huge 24bbp file!
// WARNING! The routine overwrites any existing BMP with the name name as the old JPG
var
JPG: TJpegImage;
BMP: TBitmap;
s: string;
begin
Result := False;
if not FileExists(JPGFilePath) then
exit;
try
JPG := TJpegImage.Create;
BMP := TBitmap.Create;
try
JPG.LoadFromFile(JPGFilePath);
BMP.Assign(jpg);
s := ChangeFileExt(JPGFilePath, '.bmp');
if FileExists(s) then
ShowMessageFmt('Over-writing old %s', [s]);
BMP.SaveToFile(s);
if FileExists(s) then
begin
JPGFilePath := s;
Result := True;
end;
except
On E: Exception do
MessageDlg('SplashAbout Error',
'There is something wrong with the MaskImage JPG File' +
LineEnding + 'Error detail: ' + e.message,
mtError, [mbOK], 0);
end;
finally
BMP.Free;
JPG.Free;
end;
end;
procedure TSplashAbout.ShowLicense(Sender: TObject);
// Triggered by License button Click
var
sLicenseString: string;
theList: TStringList;
f: integer;
LicenceForm: TForm;
lblText: TLabel;
closebuttton: TBitBtn;
r: TLResource;
begin
// Trap for invalid path
case fLicenseFile of
saNone: szLicenseFile := '';
saGPL: szLicenseFile := 'gpl.txt';
saLGPL: szLicenseFile := 'lgpl.txt';
saMIT: szLicenseFile := 'mit.txt';
saModifiedgpl: szLicenseFile := 'modifiedgpl.txt';
end;
if fLicenseFile = saNone then
Exit;
// if not FileExists(szLicenseFile) then exit;
// Use a string list to split the text file into lines
theList := TStringList.Create;
// Create a window, label and close button on-the-fly
LicenceForm := TForm.Create(nil);
lblText := TLabel.Create(LicenceForm);
closebuttton := TBitBtn.Create(LicenceForm);
// Load up the text into variable 'sLicenseString'
sLicenseString := LineEnding + LineEnding + fTitleString + LineEnding;
try
try
// theList.LoadFromFile(szLicenseFile);
r := LazarusResources.Find(szLicenseFile);
if r = nil then
raise Exception.Create('Resource datafile license.lrs is missing');
thelist.Add(r.Value);
for f := 0 to TheList.Count - 1 do
sLicenseString += TheList[f] + LineEnding;
except
On e: Exception do
MessageDlg('SplashAbout Error',
'There is something wrong with the Licence text', mtError, [mbOK], 0);
end;
// Replace boilerplate text if possible
sLicenseString := AnsiReplaceText(sLicenseString, '<year>',
{$I %DATE%}
);
sLicenseString := AnsiReplaceText(sLicenseString, '<name of author>', fAuthorString);
sLicenseString := AnsiReplaceText(sLicenseString, '<contact>',
'(' + fSupportContactString + ')');
sLicenseString := AnsiReplaceText(sLicenseString, '<copyright holders>',
fAuthorString);
// Make up the form window and controls
with LicenceForm do
begin
// Form
{$IFDEF WINDOWS}
// More compact GUI?
Width := C_DEFAULTLICENSEFORMWIDTH;
Height := C_DEFAULTLICENSEFORMHEIGHT;
{$ELSE WINDOWS}
Width := C_DEFAULTLICENSEFORMWIDTH_LINUX;
Height := C_DEFAULTLICENSEFORMHEIGHT_LINUX;
{$ENDIF}
// autosize:=true;
// If you enable autosize, the button placement goes awry!
// The Modified GPL has an extra clause
if (szLicenseFile = 'modifiedgpl.txt') or
(Pos('As a special exception', sLicenseString) > 0) then
Height := Height + 100;
position := poScreenCenter;
borderstyle := bsToolWindow;
Caption := fTitleString + ' Licensing';
formstyle := fsSystemStayOnTop;
// Label
lblText.Align := alClient;
lblText.Alignment := taCenter;
lblText.Caption := sLicenseString;
lblText.Parent := LicenceForm;
// Close Button
closebuttton.Kind := bkClose;
closebuttton.left := (Width div 2) - closebuttton.Width div 2;
closebuttton.top := Height - closebuttton.Height - 10;
closebuttton.parent := LicenceForm;
// Show modally over the existing modal form
ShowModal;
end;
finally
// Free up all created resources from memory
FreeAndNil(theList);
FreeAndNil(lblText);
FreeAndNil(closebuttton);
FreeAndNil(LicenceForm);
end;
end;
procedure TSplashAbout.CloseForm(Sender: TObject);
// Triggered by a Timer.OnTimer event or CloseButton.Click or OnClick
begin
fSplashForm.Close; // Hide and destroy
end;
procedure TSplashAbout.ShowSplash;
begin
// Set the mode, then create and show the form
fFormType := fSplash;
ShowForm;
end;
procedure TSplashAbout.ShowAbout;
begin
// Set the mode, then create and show the form
fFormType := fAbout;
ShowForm;
end;
procedure TSplashAbout.ShowForm;
// Main method
// Construct a form and show it modally
// Controls vary according to fFormType variable
var
okbutton, LicenseButton: TBitBtn;
Delaytimer, scrolltimer: TTimer;
lbl_Title, lbl_VersionInfo: TLabel;
img_icon, img_background: TImage;
bevel: TBevel;
MyBitMap: TBitMap;
sVersionInfoString: string;
iFormHeight, iFormWidth: integer;
szMaskName: string;
//Establish License
begin
case fLicenseFile of
saNone:
begin
szLicenseFile := '';
fLicenseTypeString := '';
end;
saGPL:
begin
szLicenseFile := 'gpl.txt';
fLicenseTypeString := 'GPL License';
end;
saLGPL:
begin
szLicenseFile := 'lgpl.txt';
fLicenseTypeString := 'Library GPL License';
end;
saMIT:
begin
szLicenseFile := 'mit.txt';
fLicenseTypeString := 'MIT License';
end;
saModifiedgpl:
begin
szLicenseFile := 'modifiedgpl.txt';
fLicenseTypeString := 'Modified GPL License';
end;
end;
case fMaskType of
saNoMask: szMaskName := 'none';
saUserImage: szMaskName := fMaskImageFilePath;
saRoundedRect: szMaskName := 'roundedrect';
saBigCog: szMaskName := 'bigcog';
saBigFlower: szMaskName := 'bigflower';
saBigSplash: szMaskName := 'bigsplash';
end;
// Temporarily create the form and controls
fSplashForm := TForm.CreateNew(nil);
if (fCreateType = saApplication) then
begin
fTitleString := Application.Title;
fIcon := Application.Icon;
end;
if (fCreateType = saForm) then
begin
fTitleString := fFormTitleString;
fIcon := fFormIcon;
end;
// The created form is parent to all the controls
bevel := TBevel.Create(fSplashForm);
okbutton := TBitBtn.Create(fSplashForm);
LicenseButton := TBitBtn.Create(fSplashForm);
Delaytimer := TTimer.Create(fSplashForm);
Scrolltimer := TTimer.Create(fSplashForm);
lbl_Title := TLabel.Create(fSplashForm);
lbl_VersionInfo := TLabel.Create(fSplashForm);
img_icon := TImage.Create(fSplashForm);
img_background := TImage.Create(fSplashForm);
MyBitmap := TBitMap.Create;
iFormHeight := C_DEFAULTSPLASHHEIGHT;
{$IFDEF LINUX}
iFormHeight := C_DEFAULTSPLASHHEIGHT_LINUX;
{$ENDIF}
iFormWidth := C_DEFAULTSPLASHWIDTH;
// Now set positions and properties
try //.. finally FreeAndNil everything
with fSplashForm do
begin
// Form
position := poScreenCenter;
if fFormType = fAbout then
borderstyle := bsToolWindow
else
borderstyle := bsnone;
Caption := 'About ' + fTitleString;
formstyle := fsSystemStayOnTop;
color := fBackGroundColor;
Height := iFormHeight;
Width := iFormWidth;
// Shaped form?
// Form is sized to mask image (MUST be BMP file)
// Text is centred in a 320 x 240 invisible frame
{$IFNDEF LINUX}// Problem with Canvas.Draw in 64-bit linux!
// Skip this mask code block if MaskType is saNoMask
if (fFormType = fSplash) and (fMaskType <> saNoMask) then
begin
// Deal with user-supplied image first
if (fMaskType = saUserImage) then
if (FileExists(fMaskImageFilePath)) then
begin
// Try to convert a jpg file if specified as such
if ExtractFileExt(fMaskImageFilePath) = '.jpg' then
if MakeBMPfromJPG(fMaskImageFilePath) = False then
MessageDlg('SplashAbout Error',
'There is something wrong with the MaskImage File',
mtError, [mbOK], 0)
else
MessageDlg('SplashAbout',
'The MaskImage should be a .BMP file. Your jpg has been converted and saved as a bmp. Please amend the property.',
mtInformation, [mbOK], 0);
// Load the user image into the BitMap
MyBitMap.LoadFromFile(fMaskImageFilePath);
end
else
// Looks like the specified user image isn't in the application folder
begin
MessageDlg('SplashAbout Error',
'Cannot find MaskImage ' + fMaskImageFilePath,
mtError, [mbOK], 0);
exit;
end;
// Stock image specified
if (fMaskType <> saUserImage) then
MyBitmap.LoadFromLazarusResource(szMaskName);
// Now to use the loaded BitMap
try
if MyBitMap.Height >= iFormHeight then
iFormHeight := MyBitMap.Height;
if MyBitMap.Width >= iFormWidth then
iFormWidth := MyBitMap.Width;
MyBitMap.Transparent := True;
MyBitMap.TransparentColor := clBlack;
Height := iFormHeight;
Width := iFormWidth;
Canvas.Draw(0, 0, MyBitMap);
// raises Floating Point Error in 64-bit Nix (!??)
SetShape(MyBitMap);
bevel.Visible := False;
except
On e: Exception do
MessageDlg('SplashAbout Error',
'There is something wrong with the MaskImage File' +
LineEnding + 'Error detail: ' + e.message,
mtError, [mbOK], 0);
end;
end;
{$ENDIF}
// bevel
// Controls are placed relative to the bevel window
bevel.Width := C_DEFAULTSPLASHWIDTH;
bevel.Height := C_DEFAULTSPLASHHEIGHT;
{$IFDEF LINUX}
bevel.Height := C_DEFAULTSPLASHHEIGHT_LINUX;
{$ENDIF}
if iFormHeight > bevel.Height then
bevel.Top := (iFormHeight - bevel.Height) div 2
else
bevel.Top := 0;
if iFormWidth > bevel.Width then
bevel.Left := (iFormWidth - bevel.Width) div 2
else
bevel.Left := 0;
bevel.BorderSpacing.Around := 4;
bevel.BorderSpacing.InnerBorder := 4;
bevel.Parent := fSplashForm;
bevel.onClick := @CloseForm;
// Close Button
if fFormType = fAbout then
begin
okbutton.Kind := bkClose;
okbutton.left := (Width div 2) - okbutton.Width div 2;
okbutton.top := Height - okbutton.Height - 10;
okbutton.parent := fSplashForm;
end;
// Delay Timer
if fFormType = fSplash then
begin
if fDelaySeconds = 0 then
fCloseOnIdle := True
else
fCloseOnIdle := False;
if FCloseOnIdle then
Application.AddOnIdleHandler(@ApplicationOnIdle)
else
begin
// Fix negative values
if fDelaySeconds < 1 then
fDelaySeconds := 1;
// Fix developer mistakenly specifying milliseconds
if fDelaySeconds > 1000 then
fDelaySeconds := fDelaySeconds div 1000;
delaytimer.Interval := fDelaySeconds * 1000;
delaytimer.OnTimer := @CloseForm;
delaytimer.Enabled := True;
end;
end;
// Icon
img_icon.Width := 32;
img_icon.Height := 32;
img_icon.Top := bevel.Top + 20;
img_icon.Left := bevel.left + (bevel.Width - 32 - 20);
img_icon.Stretch := True;
fIcon := Application.Icon; // Initialises the Icon object
try
if FileExists(fIconFilePath) then
begin
fIcon.LoadFromFile(fIconFilePath);
end;
if fIcon <> nil then
img_icon.Picture.Icon := fIcon
else
img_icon.Picture.Icon := Application.Icon;
img_icon.Parent := fSplashForm;
except
On e: Exception do
MessageDlg('SplashAbout Error', 'There is something wrong with the Icon File',
mtError, [mbOK], 0);
end;
// BackGround
if FileExists(fBackGroundImageFilePath) then
begin
img_background.Align := alClient;
img_background.Stretch := True;
try
img_background.Picture.LoadFromFile(fBackGroundImageFilePath);
img_background.Parent := fSplashForm;
img_background.SendToBack;
except
On e: Exception do
MessageDlg('SplashAbout Error',
'There is something wrong with the BackgroundImage', mtError, [mbOK], 0);
end;
end;
// Title
if fFormType = fSplash then
begin
lbl_Title.Top := bevel.Top + 64;
lbl_Title.Left := bevel.Left;
lbl_Title.AutoSize := False;
lbl_Title.Width := bevel.Width;
lbl_Title.Font.Size := 12;
lbl_Title.Font.Style := [];
lbl_Title.Height := 32;
lbl_Title.Alignment := taCenter;
if (fTitleString = '') then
lbl_Title.Caption := Application.Title
else
lbl_Title.Caption := fTitleString;
lbl_Title.Parent := fSplashForm;
end;
// License Button
if (fFormType = fAbout) and (LazarusResources.Find(szLicenseFile) <> nil) then
begin
LicenseButton.Top := okButton.Top;
LicenseButton.Caption := 'License...';
LicenseButton.left := Width - LicenseButton.Width - 10;
LicenseButton.OnClick := @ShowLicense;
LicenseButton.Parent := fSplashForm;
end;
// Version Info
lbl_VersionInfo.Autosize := False;
lbl_VersionInfo.WordWrap := True;
lbl_VersionInfo.Left := bevel.left + 40;
lbl_VersionInfo.Width := bevel.Width - 50;
lbl_VersionInfo.Height := bevel.Height - 50;
sVersionInfoString := '';
if fFormType = fAbout then
sVersionInfoString += fTitleString;
if fCreditString <> '' then
sVersionInfoString += LineEnding + fCreditString;
// Show description or VersionInfo?
if (fShowDescription = True) and (fDescription <> '') then
sVersionInfoString += fAppVersionString + LineEnding + fDescription
else
sVersionInfoString += LineEnding + fVersionInfoString;
if fLicenseTypeString <> '' then
sVersionInfoString += LineEnding + LineEnding + 'Released under ' +
fLicenseTypeString;
lbl_VersionInfo.Caption := sVersionInfoString;
if fFormType = fSplash then
lbl_VersionInfo.Top :=
Bevel.Top + (bevel.Height div 2) - 50
else
lbl_VersionInfo.Top := 40;
lbl_VersionInfo.Parent := fSplashForm;
lbl_VersionInfo.onClick := @CloseForm;
// Now show the completed form
Application.ProcessMessages;
ShowModal;
// Application.ProcessMessages;
end;
finally
// Controls normally destroyed with parent
// but if Try block fails, ensure no memory leaks
FreeAndNil(bevel);
FreeAndNil(img_icon);
FreeAndNil(img_background);
FreeAndNil(lbl_Title);
FreeAndNil(lbl_VersionInfo);
FreeAndNil(okbutton);
FreeAndNil(LicenseButton);
FreeAndNil(delaytimer);
FreeAndNil(Scrolltimer);
FreeAndNil(MyBitMap);
FreeAndNil(fSplashForm);
end;
end;
initialization
{$I license.lrs}
{$I masks.lrs}
end.

295
components/splashabout/uversion.pas Normal file
View File

@ -0,0 +1,295 @@
Unit uversion;
{$mode objfpc}
Interface
(*
Building on the excellent vinfo.pas supplied by Paul Ishenin and available elsewhere on these Lazarus
Forums
- I hid the TVersionInfo class from the end user to simplify their (mine) number of required Uses...
- Added defensive code to TVersionInfo if no build info is compiled into the exe
- Deduced GetResourceStrings - works under Linux 64/GTK2 with Lazarus 0.9.30, but fails under
Win XP 32bit/Lazarus 0.9.29 - suspecting my install as the lazresexplorer example also fails
for me under Lazarus 0.9.29, but works with Lazarus 0.9.30
Trawled through IDE source code, FPC source code and Lazarus supplied example program lasresexplorer
to find the other defines and lookups...
End user only needs to use uVersion - no other units necessary for their project.
Jedi CodeFormatter seems to fail on the {$I %VARIABLE%} references, so sticking them all in here
means end user code can be neatly formatted using Jedi CodeFormatter
Other interesting includes I picked up in my travels are...
// {$I %HOME%} = User Home Directory
// {$I %FILE%} = Current pas file
// {$I %LINE%} = current line number
Mike Thompson - mike.cornflake@gmail.com
July 24 2011
2018: Updated for changes in Widgetset detection in Lazarus V1.8
*)
Uses
Classes, SysUtils;
Function GetFileVersion: String;
Function GetProductVersion: String;
Function GetMajorProductVersion: Cardinal;
Function GetMinorProductVersion: Cardinal;
Function GetRevisionProductVersion: Cardinal;
Function GetBuildProductVersion: Cardinal;
Function GetCompiledDate: String;
Function GetCompilerInfo: String;
Function GetTargetInfo: String;
Function GetOS: String;
Function GetResourceStrings(oStringList : TStringList) : Boolean;
Function GetLCLVersion: String;
function GetWidgetSet: string;
function Reload(Inst:THandle):Boolean;
Implementation
Uses
resource, versiontypes, versionresource, InterfaceBase,LCLVersion,LCLPlatformDef;
Type
TVersionInfo = Class
private
FBuildInfoAvailable: Boolean;
FVersResource: TVersionResource;
Function GetFixedInfo: TVersionFixedInfo;
Function GetStringFileInfo: TVersionStringFileInfo;
Function GetVarFileInfo: TVersionVarFileInfo;
public
Constructor Create;
Destructor Destroy; override;
Procedure Load(Instance: THandle);
Property BuildInfoAvailable: Boolean Read FBuildInfoAvailable;
Property FixedInfo: TVersionFixedInfo Read GetFixedInfo;
Property StringFileInfo: TVersionStringFileInfo Read GetStringFileInfo;
Property VarFileInfo: TVersionVarFileInfo Read GetVarFileInfo;
End;
function GetWidgetSet: string;
begin
Result:=GetLCLWidgetTypeName;
end;
Function GetCompilerInfo: String;
begin
Result := 'FPC '+{$I %FPCVERSION%};
end;
Function GetTargetInfo: String;
begin
Result := {$I %FPCTARGETCPU%}+' - '+{$I %FPCTARGETOS%};
end;
Function GetOS: String;
Begin
Result := {$I %FPCTARGETOS%};
End;
Function GetLCLVersion: String;
begin
Result := 'LCL '+ lcl_version;
end;
Function GetCompiledDate: String;
Var
sDate, sTime: String;
Begin
sDate := {$I %DATE%};
sTime := {$I %TIME%};
Result := sDate + ' at ' + sTime;
End;
{ Routines to expose TVersionInfo data }
Var
FInfo: TVersionInfo;
Procedure CreateInfo;
Begin
If Not Assigned(FInfo) Then
Begin
FInfo := TVersionInfo.Create;
FInfo.Load(HINSTANCE);
End;
End;
Function GetResourceStrings(oStringList: TStringList): Boolean;
Var
i, j : Integer;
oTable : TVersionStringTable;
begin
CreateInfo;
oStringList.Clear;
Result := False;
If FInfo.BuildInfoAvailable Then
Begin
Result := True;
For i := 0 To FInfo.StringFileInfo.Count-1 Do
Begin
oTable := FInfo.StringFileInfo.Items[i];
For j := 0 To oTable.Count-1 Do
If Trim(oTable.ValuesByIndex[j])<>'' Then
oStringList.Values[oTable.Keys[j]] := oTable.ValuesByIndex[j];
end;
end;
end;
Function ProductVersionToString(PV: TFileProductVersion): String;
Begin
Result := Format('%d.%d.%d.%d', [PV[0], PV[1], PV[2], PV[3]]);
End;
Function GetMajorProductVersion: Cardinal;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := FInfo.FixedInfo.ProductVersion[0]
Else
Result := 0;
End;
Function GetMinorProductVersion: Cardinal;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := FInfo.FixedInfo.ProductVersion[1]
Else
Result := 0;
End;
Function GetRevisionProductVersion: Cardinal;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := FInfo.FixedInfo.ProductVersion[2]
Else
Result := 0;
End;
Function GetBuildProductVersion: Cardinal;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := FInfo.FixedInfo.ProductVersion[3]
Else
Result := 0;
End;
Function GetProductVersion: String;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := ProductVersionToString(FInfo.FixedInfo.ProductVersion)
Else
Result := 'No build information available';
End;
{%H-}Function Reload(Inst:THandle):Boolean;
begin
FreeAndNil(FInfo);
If Not Assigned(FInfo) Then
Begin
FInfo := TVersionInfo.Create;
FInfo.Load(Inst);
End;
end;
Function GetFileVersion: String;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := ProductVersionToString(FInfo.FixedInfo.FileVersion)
Else
Result := 'No build information available';
End;
{ TVersionInfo }
Function TVersionInfo.GetFixedInfo: TVersionFixedInfo;
Begin
Result := FVersResource.FixedInfo;
End;
Function TVersionInfo.GetStringFileInfo: TVersionStringFileInfo;
Begin
Result := FVersResource.StringFileInfo;
End;
Function TVersionInfo.GetVarFileInfo: TVersionVarFileInfo;
Begin
Result := FVersResource.VarFileInfo;
End;
Constructor TVersionInfo.Create;
Begin
Inherited Create;
FVersResource := TVersionResource.Create;
FBuildInfoAvailable := False;
End;
Destructor TVersionInfo.Destroy;
Begin
FVersResource.Free;
Inherited Destroy;
End;
Procedure TVersionInfo.Load(Instance: THandle);
Var
Stream: TResourceStream;
ResID: Integer;
Res: TFPResourceHandle;
Begin
FBuildInfoAvailable := False;
ResID := 1;
// Defensive code to prevent failure if no resource available...
Res := FindResource(Instance, {%H-}PChar(PtrInt(ResID)), {%H-}PChar(RT_VERSION));
If Res = 0 Then
Exit;
Stream := TResourceStream.CreateFromID(Instance, ResID, PChar(RT_VERSION));
Try
FVersResource.SetCustomRawDataStream(Stream);
// access some property to load from the stream
FVersResource.FixedInfo;
// clear the stream
FVersResource.SetCustomRawDataStream(nil);
FBuildInfoAvailable := True;
Finally
Stream.Free;
End;
End;
Initialization
FInfo := nil;
Finalization
If Assigned(FInfo) Then
FInfo.Free;
End.