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

Altered directory structure

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5486 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
2016-12-14 12:44:01 +00:00
parent 524091bb0d
commit 83efb925e7
12 changed files with 5779 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

643
components/lazautoupdate/latest_stable/aboutlazautoupdateunit.pas Normal file
View File

@ -0,0 +1,643 @@
{ TAboutLazAutoUpdate and TAboutBox Component License
Copyright (C) 2014 Gordon Bamber minesadorada@charcodelvalle.com
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
}
unit aboutlazautoupdateunit;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, Dialogs, Forms, Graphics, LResources, SysUtils,
ExtCtrls, StdCtrls, StrUtils, Buttons, PropEdits;
const
C_DEFAULTLICENSEFORMWIDTH = 500;
C_DEFAULTLICENSEFORMWIDTH_LINUX = C_DEFAULTLICENSEFORMWIDTH + 100;
C_DEFAULTLICENSEFORMHEIGHT = 400;
C_DEFAULTLICENSEFORMHEIGHT_LINUX = C_DEFAULTLICENSEFORMHEIGHT + 50;
type
TLicenseType = (abNone, abGPL, abLGPL, abMIT, abModifiedGPL, abProprietry);
TAboutbox = class(TComponent)
private
{ Private declarations }
fDialog: TForm;
fBackgroundbitmap: TBitMap;
fBackgroundResourceName: string;
fDescription: TStrings;
fDialogTitle, fVersion, fAuthorname, fAuthorEmail, fOrganisation,
fComponentName: string;
fDialogHeight, fDialogWidth: integer;
fStretchBackground: boolean;
fFont: TFont;
fColor: TColor;
fLicenseType: TLicenseType;
procedure SetBackgroundBitmap(const AValue: TBitMap);
procedure SetDescriptionStrings(const AValue: TStrings);
procedure SetFont(const AValue: TFont);
procedure ShowLicense(Sender: TObject);
procedure SetDialogTitle(const AValue: string);
protected
{ Protected declarations }
public
{ Public declarations }
procedure ShowDialog;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
// Set these properties in your component Constructor method
property BackGround: TBitMap read fBackgroundbitmap write SetBackgroundBitmap;
property BackgroundResourceName: string
read fBackgroundResourceName write fBackgroundResourceName;
property Description: TStrings read fDescription write SetDescriptionStrings;
property Title: string read fDialogTitle write SetDialogTitle;
property Height: integer read fDialogHeight write fDialogHeight;
property Width: integer read fDialogWidth write fDialogWidth;
property Font: TFont read fFont write SetFont;
property BackGroundColor: TColor read fColor write fColor;
property StretchBackground: boolean read fStretchBackground
write fStretchBackground default False;
property Version: string read fVersion write fVersion;
property Authorname: string read fAuthorname write fAuthorname;
property Organisation: string read fOrganisation write fOrganisation;
property AuthorEmail: string read fAuthorEmail write fAuthorEmail;
property ComponentName: string read fComponentName write fComponentName;
property LicenseType: TLicenseType read fLicenseType write fLicenseType;
end;
TAboutLazAutoUpdate = class(TComponent)
private
{ Private declarations }
fAboutBox: tAboutBox;
procedure SetMyComponentName(const Avalue: string);
procedure SetAboutBoxWidth(const AValue: integer);
procedure SetAboutBoxHeight(const AValue: integer);
procedure SetAboutBoxDescription(const AValue: string);
procedure SetAboutBoxFontName(const AValue: string);
procedure SetAboutBoxFontSize(const AValue: integer);
procedure SetAboutBoxBitmap(const AValue: TBitmap);
procedure SetAboutBoxBackgroundColor(const AValue: TColor);
procedure SetAboutBoxTitle(const AValue: string);
procedure SetAboutBoxVersion(const AValue: string);
procedure SetAboutBoxAuthorname(const AValue: string);
procedure SetAboutBoxOrganisation(const AValue: string);
procedure SetAboutBoxAuthorEmail(const AValue: string);
procedure SetAboutBoxBackgroundResourceName(const AValue: string);
procedure SetAboutBoxLicenseType(const AValue: string);
procedure SetAboutBoxStretchBackgroundImage(const AValue: boolean);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override; // Constructor must be public
destructor Destroy; override; // Destructor must be public
// Set these (hidden) properties in your inherited component's Create procedure
property AboutBoxComponentName: string write SetMyComponentName;
property AboutBoxWidth: integer write SetAboutBoxWidth;
property AboutBoxHeight: integer write SetAboutBoxHeight;
property AboutBoxDescription: string write SetAboutBoxDescription;
property AboutBoxFontName: string write SetAboutBoxFontName;
property AboutBoxFontSize: integer write SetAboutBoxFontSize;
property AboutBoxBackgroundColor: TColor write SetAboutBoxBackgroundColor;
property AboutBoxTitle: string write SetAboutBoxTitle;
property AboutBoxVersion: string write SetAboutBoxVersion;
property AboutBoxAuthorname: string write SetAboutBoxAuthorname;
property AboutBoxOrganisation: string write SetAboutBoxOrganisation;
property AboutBoxAuthorEmail: string write SetAboutBoxAuthorEmail;
property AboutBoxLicenseType: string write SetAboutBoxLicenseType;
property AboutBoxBackgroundResourceName: string
write SetAboutBoxBackgroundResourceName;
property AboutBoxStretchBackgroundImage: boolean
write SetAboutBoxStretchBackgroundImage;
published
// The clickable 'About' property will automaticcally appear in any component
// descended from TAboutLazAutoUpdate
// About this component...
property About: tAboutBox read fAboutBox write fAboutBox;
end;
// Declaration for the 'About' property editor
TAboutPropertyEditor = class(TClassPropertyEditor)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
end;
procedure Register;
{For i8n if required}
resourcestring
rs_Componentname = 'Component name';
rs_About = 'About';
rs_License = 'License';
rs_By = 'By';
rs_For = 'For';
rs_DatafileMissing = 'Resource datafile license.lrs is missing';
rs_LicenseTextError = 'There is something wrong with the Licence text';
rs_AboutBoxError = 'Subcomponent TAboutBox Error';
implementation
{ TABoutBox}
constructor TAboutbox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fBackgroundbitmap := TBitMap.Create;
fDescription := TStringList.Create;
fFont := TFont.Create;
fColor := clDefault;
fLicenseType := abNone;
fComponentName := rs_Componentname;
fDialogTitle := rs_About + ' ' + fComponentName;
fDialogWidth := 320;
fDialogHeight := 280;
fVersion := '1.0.0.1';
fLicenseType := abNone;
end;
destructor TAboutbox.Destroy;
begin
FreeAndNil(fFont);
FreeAndNil(fDescription);
FreeAndNil(fBackgroundbitmap);
inherited Destroy;
end;
procedure TAboutbox.SetDialogTitle(const AValue: string);
begin
if AnsiContainsText(fDialogTitle, rs_About) then
fDialogTitle := AValue
else
fDialogTitle := rs_About + ' ' + Avalue;
end;
procedure TAboutbox.ShowDialog;
var
OKbutton, LicenseButton: TBitBtn;
lbl_Description: TLabel;
img_BackGround: TImage;
sz: string;
iCount: integer;
r: TLResource;
begin
fDialog := TForm.CreateNew(nil);
try //.. finally FreeAndNil everything
with fDialog do
begin
// Set Dialog properties
position := poScreenCenter;
borderstyle := bsToolWindow;
Caption := fDialogTitle;
formstyle := fsSystemStayOnTop;
color := fColor;
font := fFont;
if (fDialogHeight > 0) then
Height := fDialogHeight
else
Height := 240;
if (fDialogWidth > 0) then
Width := fDialogWidth
else
Width := 320;
// Create a background image
img_BackGround := Timage.Create(fDialog);
with img_BackGround do
// Set img_BackGround properties
begin
Align := alClient;
Stretch := fStretchBackground;
// Bitmap assigned?
if Assigned(fBackgroundbitmap) then
Picture.Assign(fBackgroundbitmap);
// Resource file?
r := LazarusResources.Find(fBackgroundResourceName);
if r <> nil then
img_BackGround.Picture.LoadFromLazarusResource(fBackgroundResourceName);
SendToBack;
parent := fDialog;
end;
// Create a BitBtn button
okbutton := TBitBtn.Create(fDialog);
// Set BitBtn properties
with okButton do
begin
Kind := bkClose;
left := (fDialog.Width div 2) - Width div 2;
top := fDialog.Height - Height - 10;
ParentFont := False;
parent := fDialog;
end;
// Create a License Button
LicenseButton := TBitBtn.Create(fDialog);
if (fLicenseType <> abNone) then
// Put it on the right
begin
LicenseButton.Top := OKButton.Top;
LicenseButton.Caption := rs_License + '...';
LicenseButton.left := Width - LicenseButton.Width - 10;
LicenseButton.OnClick := @ShowLicense;
LicenseButton.ParentFont := False;
LicenseButton.Parent := fDialog;
end;
// Create a label control
lbl_Description := Tlabel.Create(fDialog);
// Set label properties
with lbl_Description do
begin
left := 8;
Top := 30;
Width := fDialog.Width - 8;
Height := fDialog.Height - 30;
Autosize := False;
ParentFont := True;
Alignment := taCenter;
end;
// Build up Label text
sz := '';
// Component name
if fComponentName <> '' then
sz += fComponentName + LineEnding;
// Author name (+Email)
if fAuthorname <> '' then
sz += rs_By + ': ' + fAuthorname + LineEnding;
if fAuthorEmail <> '' then
sz += ' (' + fAuthorEmail + ')' + LineEnding
else
sz += LineEnding;
sz += LineEnding;
// Version
if fVersion <> '' then
sz += 'Version: ' + fVersion + LineEnding;
// License
case fLicenseType of
abGPL: sz += rs_License + ': GPL' + LineEnding;
abLGPL: sz += rs_License + ': LGPL' + LineEnding;
abMIT: sz += rs_License + ': M.I.T.' + LineEnding;
abModifiedGPL: sz += rs_License + ': Modified GPL' + LineEnding;
abProprietry: sz += rs_License + ': Proprietry' + LineEnding;
end;
if fOrganisation <> '' then
sz += rs_For + ': ' + fOrganisation + LineEnding;
if fDescription.Count > 0 then
begin
sz += LineEnding;
for iCount := 1 to fDescription.Count do
sz += fDescription[iCount - 1] + LineEnding;
end;
lbl_Description.Caption := sz;
lbl_Description.parent := fDialog;
// Display the dialog modally
ShowModal;
end;
finally
// Free all resources
FreeAndNil(img_BackGround);
FreeAndNil(lbl_Description);
FreeAndNil(LicenseButton);
FreeAndNil(okbutton);
end;
end;
procedure TAboutbox.ShowLicense(Sender: TObject);
// Triggered by License button Click
var
sLicenseString: string;
theList: TStringList;
f: integer;
LicenceForm: TForm;
lblText: TLabel;
closebuttton: TBitBtn;
r: TLResource;
szLicenseFile: string;
begin
// Quit early?
if fLicenseType = abNone then
Exit;
// Set to resource name in license.lrs
case fLicenseType of
abNone: szLicenseFile := '';
abGPL: szLicenseFile := 'gpl.txt';
abLGPL: szLicenseFile := 'lgpl.txt';
abMIT: szLicenseFile := 'mit.txt';
abModifiedgpl: szLicenseFile := 'modifiedgpl.txt';
end;
// 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 + fComponentName + LineEnding;
try
try
begin
// Load license text from resource string
r := LazarusResources.Find(szLicenseFile);
if r = nil then
raise Exception.Create(rs_DatafileMissing);
thelist.Add(r.Value);
for f := 0 to TheList.Count - 1 do
sLicenseString += TheList[f] + LineEnding;
end;
except
On e: Exception do
MessageDlg(rs_AboutBoxError,
rs_LicenseTextError, mtError, [mbOK], 0);
end;
// Replace boilerplate text if possible
sLicenseString := AnsiReplaceText(sLicenseString, '<year>',
{$I %DATE%}
);
sLicenseString := AnsiReplaceText(sLicenseString, '<name of author>', fAuthorname);
sLicenseString := AnsiReplaceText(sLicenseString, '<contact>',
'(' + fAuthorEmail + ')');
sLicenseString := AnsiReplaceText(sLicenseString, '<copyright holders>',
fOrganisation);
// 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 := fComponentName + ': 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
PopupParent := TForm(Sender);
ShowModal;
end;
finally
// Free up all component created resources from memory
FreeAndNil(theList);
FreeAndNil(lblText);
FreeAndNil(closebuttton);
FreeAndNil(LicenceForm);
end;
end;
procedure TAboutbox.SetBackgroundBitmap(const AValue: TBitMap);
begin
if Assigned(AValue) then
fBackgroundbitmap.Assign(AValue);
end;
procedure TAboutbox.SetDescriptionStrings(const AValue: TStrings);
begin
if Assigned(AValue) then
fDescription.Assign(Avalue);
end;
procedure TAboutbox.SetFont(const AValue: TFont);
begin
if Assigned(AValue) then
fFont.Assign(AValue);
end;
{ TAboutLazAutoUpdate }
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TAboutbox),
TAboutLazAutoUpdate, 'About', TAboutPropertyEditor);
end;
procedure TAboutPropertyEditor.Edit;
// Communicate with the component properties
var
AAboutBox: TAboutBox;
begin
AAboutBox := TAboutBox(GetObjectValue(TAboutBox));
AABoutBox.ShowDialog;
end;
function TAboutPropertyEditor.GetAttributes: TPropertyAttributes;
// Show the ellipsis
begin
Result := [paDialog, paReadOnly];
end;
// Sets for AboutBox dialog properties
procedure TAboutLazAutoUpdate.SetMyComponentName(const Avalue: string);
begin
fAboutBox.ComponentName := AValue;
fAboutBox.Title := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxWidth(const AValue: integer);
begin
fAboutBox.Width := Avalue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxHeight(const AValue: integer);
begin
fAboutBox.Height := Avalue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxDescription(const AValue: string);
begin
fAboutBox.Description.Clear;
fAboutBox.Description.Add(AValue);
end;
procedure TAboutLazAutoUpdate.SetAboutBoxFontName(const AValue: string);
begin
fAboutBox.Font.Name := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxFontSize(const AValue: integer);
begin
if (AValue > 6) then
fAboutBox.Font.Size := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxTitle(const AValue: string);
begin
fAboutBox.Title := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxBitmap(const AValue: TBitmap);
begin
if Assigned(Avalue) then
fAboutBox.Assign(AValue);
end;
procedure TAboutLazAutoUpdate.SetAboutBoxBackgroundColor(const AValue: TColor);
begin
fAboutBox.BackGroundColor := AValue;
;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxVersion(const AValue: string);
begin
fAboutBox.Version := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxAuthorname(const AValue: string);
begin
fAboutBox.Authorname := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxOrganisation(const AValue: string);
begin
fAboutBox.Organisation := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxAuthorEmail(const AValue: string);
begin
fAboutBox.AuthorEmail := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxBackgroundResourceName(const AValue: string);
begin
fAboutBox.BackgroundResourceName := AValue;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxLicenseType(const AValue: string);
begin
case Upcase(AValue) of
'GPL': fAboutBox.LicenseType := abGPL;
'LGPL': fAboutBox.LicenseType := abLGPL;
'MIT': fAboutBox.LicenseType := abMIT;
'MODIFIEDGPL': fAboutBox.LicenseType := abModifiedGPL;
'PROPRIETRY': fAboutBox.LicenseType := abProprietry;
else
fAboutBox.LicenseType := abNone;
end;
end;
procedure TAboutLazAutoUpdate.SetAboutBoxStretchBackgroundImage(const AValue: boolean);
begin
fAboutBox.StretchBackground := AValue;
end;
// End Sets
constructor TAboutLazAutoUpdate.Create(AOwner: TComponent);
var
TempImage: TPicture;
r: TLResource;
begin
// Inherit default properties
inherited Create(AOwner);
// Use tAboutBox as a subcomponent
fAboutBox := tAboutBox.Create(nil);
with fAboutBox do
begin
SetSubComponent(True); // Tell the IDE to store the modified properties
// Default of TAboutLazAutoUpdate values override TAbouBox.Create defaults
ComponentName := 'TAboutLazAutoUpdate';
Description.Add('This is to demonstrate'); //TStrings
Description.Add('the use of TAboutLazAutoUpdate'); //TStrings
Description.Add('Set its properties in your Constructor'); //TStrings
Width := 320; //Integer
Height := 280; //Integer
// Set any Font properties or subproperties here
// Font.Name := 'Arial';
Font.Color := clNavy;
Font.Size := 10;
// BackGroundColor shows if no BackGround image is set
BackGroundColor := clWindow;
Version := '1.0.0.0';
AuthorName := 'Gordon Bamber';
AuthorEmail := 'minesadorada@charcodelvalle.com';
Organisation := 'Public Domain';
//Types available: abNone, abGPL, abLGPL, abMIT, abModifiedGPL, abProprietry
LicenseType := abLGPL;
// BackGround image is optional
// It must be in a resouce file in the initialization section
//== How to set a background image to your About dialog --
// The BackGround property is a TBitmap
// Use a Temporary TPicture to load a JPG.
// NOTE a PNG file will create an error when your component is used in an application!
r := LazarusResources.Find(fAboutBox.BackgroundResourceName);
if r <> nil then
begin
TempImage := TPicture.Create;
// .lrs file is in the initialization section
TempImage.LoadFromLazarusResource(fAboutBox.BackgroundResourceName);
BackGround.Assign(TempImage.Bitmap);
TempImage.Free;
StretchBackground := fAboutBox.StretchBackground; //Boolean
end;
end;
end;
destructor TAboutLazAutoUpdate.Destroy;
begin
FreeAndNil(fAboutBox);
inherited Destroy;
end;
initialization
{$I license.lrs}
end.

2102
components/lazautoupdate/latest_stable/alt_lazautoupdate_icon.lrs Normal file
View File

File diff suppressed because it is too large Load Diff

BIN
components/lazautoupdate/latest_stable/lazautoupdate.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 365 B

17
components/lazautoupdate/latest_stable/lazautoupdate_icon.lrs Normal file
View File

@ -0,0 +1,17 @@
LazarusResources.Add('TLazAutoUpdate','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#1'4IDATH'#199#197'UA'#146#132' '#12#12#17'~!('#252#255'M'#160#190'C'#201
+#158'b'#165#16#29#176'fjsS '#157'4'#157#6#224#199#161#158#22#173#181#132#136
+#128#136#160#212'uk'#206#25'r'#206#176'm'#155#234#6#152#231#153#16#177#169'J'
+'"'#130#148#146'j'#2#176#214#146'1'#230#252#142'1>v'#25'B '#217#209#178','
+#234#22#160'7y'#11#136#150#27'9yk'#226#178#144#16#194#133'V'#148#156#127'K9'
+#178'#'#5#0#224#156'#'#173'uw'#245#165#16'b'#140#138#147#243#197'k'#0#0#222
+#244'&yy'#134'AX'#214'('#1'z'#130#168#141'Q]'#251#233#156#163'a'#24'.'#255'Y'
+#235#222#251#179'B'#239'='#149#235'Dt'#14'f'#21#224#211'}'#164#148#20#131#212
+#6'L'#2#224''''#233#253#132'"'#150#154'LBD'#151')}'#13'PV'#239#189#167#30'!H'
+'c'#196#150'v'#247'}'#239#179'h'#1#160'KZb'#140'J*'#163'<'#192'qG'#215'4MT5;'
+#158#192#154'#'#182#134'4K'#166#25'K'#222#223#12#221#147#188#245#157#130#142
+#227#128'u]'#155':'#25#199#145#140'1U*U'#239#3'R'#227'\N}'#169'@'#213'b'#185
+'D'#4'9'#231#139'RJ'''#237'~'#244'%H'#203#131#243'/'#241#7#176#231#186#157
+#179'a'#247#169#0#0#0#0'IEND'#174'B`'#130
]);

98
components/lazautoupdate/latest_stable/lazupdate.lpk Normal file
View File

@ -0,0 +1,98 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="lazupdate"/>
<Type Value="RunAndDesignTime"/>
<Author Value="minesadorada@charcodelvalle.com"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="synapse\source\lib"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
</CompilerOptions>
<Description Value="Laz AutoUpdater
A component for SourceForge Project Developers and end-users to update their apps easily"/>
<License Value=" Copyright (C)2014 minesadorada@charcodelvalle.com
Modified GPL
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
"/>
<Version Minor="1" Release="28"/>
<Files Count="4">
<Item1>
<Filename Value="ulazautoupdate.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="ulazautoupdate"/>
</Item1>
<Item2>
<Filename Value="aboutlazautoupdateunit.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="aboutlazautoupdateunit"/>
</Item2>
<Item3>
<Filename Value="versionsupport.pas"/>
<UnitName Value="VersionSupport"/>
</Item3>
<Item4>
<Filename Value="uappisrunning.pas"/>
<UnitName Value="uappisrunning"/>
</Item4>
</Files>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="locale"/>
<EnableI18NForLFM Value="True"/>
</i18n>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="laz_synapse40_1"/>
</Item1>
<Item2>
<PackageName Value="IDEIntf"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<CustomOptions Value="-dUseCThreads"/>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="C:\NewPascal\lazarus\components\lazautoupdate\published"/>
</PublishOptions>
</Package>
</CONFIG>

23
components/lazautoupdate/latest_stable/lazupdate.pas Normal file
View File

@ -0,0 +1,23 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit lazupdate;
interface
uses
ulazautoupdate, aboutlazautoupdateunit, VersionSupport, uappisrunning,
LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('ulazautoupdate', @ulazautoupdate.Register);
RegisterUnit('aboutlazautoupdateunit', @aboutlazautoupdateunit.Register);
end;
initialization
RegisterPackage('lazupdate', @Register);
end.

72
components/lazautoupdate/latest_stable/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.'
]);

35
components/lazautoupdate/latest_stable/locale/aboutlazautoupdateunit.po Normal file
View File

@ -0,0 +1,35 @@
msgid ""
msgstr "Content-Type: text/plain; charset=UTF-8"
#: aboutlazautoupdateunit.rs_about
msgid "About"
msgstr ""
#: aboutlazautoupdateunit.rs_aboutboxerror
msgid "Subcomponent TAboutBox Error"
msgstr ""
#: aboutlazautoupdateunit.rs_by
msgid "By"
msgstr ""
#: aboutlazautoupdateunit.rs_componentname
msgid "Component name"
msgstr ""
#: aboutlazautoupdateunit.rs_datafilemissing
msgid "Resource datafile license.lrs is missing"
msgstr ""
#: aboutlazautoupdateunit.rs_for
msgid "For"
msgstr ""
#: aboutlazautoupdateunit.rs_license
msgid "License"
msgstr ""
#: aboutlazautoupdateunit.rs_licensetexterror
msgid "There is something wrong with the Licence text"
msgstr ""

149
components/lazautoupdate/latest_stable/locale/ulazautoupdate.po Normal file
View File

@ -0,0 +1,149 @@
msgid ""
msgstr "Content-Type: text/plain; charset=UTF-8"
#: ulazautoupdate.c_cannotloadfromremote
msgid "Cannot load document from remote server"
msgstr ""
#: ulazautoupdate.c_checking
msgid "Checking for updates..."
msgstr ""
#: ulazautoupdate.c_componentprettyname
msgid "Lazarus Auto-Update Component"
msgstr ""
#: ulazautoupdate.c_consoletitle
msgid "Updating %s"
msgstr ""
#: ulazautoupdate.c_directoryproblems
msgid "Problems with the % directory"
msgstr ""
#: ulazautoupdate.c_downloadedbytes
msgid "Downloaded %s: %d bytes"
msgstr ""
#: ulazautoupdate.c_downloadfailederrorcode
msgid "Download failed with error code "
msgstr ""
#: ulazautoupdate.c_downloading
msgid "Please wait. Downloading new version... "
msgstr ""
#: ulazautoupdate.c_downloadisempty
msgid "Downloaded document is empty."
msgstr ""
#: ulazautoupdate.c_downloadsuccess
msgid "Downloaded new version %s sucessfully."
msgstr ""
#: ulazautoupdate.c_error404
msgid "Cannot find the file at this time. (error %d) Try again later?"
msgstr ""
#: ulazautoupdate.c_error500
msgid "There is a problem with the Internet connection (error %d) Try again later?"
msgstr ""
#: ulazautoupdate.c_foldermissing
msgid "Missing %s folder"
msgstr ""
#: ulazautoupdate.c_nosftypes
msgid "Sorry only ProjectType = auSourceForge is supported in this version"
msgstr ""
#: ulazautoupdate.c_notapplicable
msgid "<not applicable>"
msgstr ""
#: ulazautoupdate.c_notproperfilename
msgid "This is not a proper file name"
msgstr ""
#: ulazautoupdate.c_ok
msgid "OK"
msgstr ""
#: ulazautoupdate.c_pleasewaitprocessing
msgid "Please wait. Processing...."
msgstr ""
#: ulazautoupdate.c_propisempty
msgid "Property SFProjectName is empty!"
msgstr ""
#: ulazautoupdate.c_sourceforgedownload
msgid "SourceForge download"
msgstr ""
#: ulazautoupdate.c_takingtoolong
msgid "Check is taking too long (bad/slow internet connection?). Try again later?"
msgstr ""
#: ulazautoupdate.c_tempversionsininame
msgid "new%s"
msgstr ""
#: ulazautoupdate.c_threaddownloadcrash
msgctxt "ulazautoupdate.c_threaddownloadcrash"
msgid "ThreadDownloadHTTP Crashed! (NewVersionAvailable)"
msgstr ""
#: ulazautoupdate.c_threaddownloadhttpcrash
msgctxt "ulazautoupdate.c_threaddownloadhttpcrash"
msgid "ThreadDownloadHTTP Crashed! (NewVersionAvailable)"
msgstr ""
#: ulazautoupdate.c_threadstarted
msgid "Thread Started"
msgstr ""
#: ulazautoupdate.c_unabletodelete
msgid "Sorry, unable to delete %s%sPlease delete it manually"
msgstr ""
#: ulazautoupdate.c_unabletodeleteold
msgid "Unable to delete old files in %s"
msgstr ""
#: ulazautoupdate.c_unabletodownload
msgid "Unable to download new version%sReturn code was %d"
msgstr ""
#: ulazautoupdate.c_updatermissing
msgid "Missing %s"
msgstr ""
#: ulazautoupdate.c_whatsnewinversion
msgid "What's new in version %s"
msgstr ""
#: ulazautoupdate.rsanewversions
msgid "A new version %s is available. Would you like to download it?"
msgstr ""
#: ulazautoupdate.rscancelledyou
msgid "Cancelled. You can download and update to the new version later."
msgstr ""
#: ulazautoupdate.rscancelledyou2
msgid "Cancelled. You can download the new version later."
msgstr ""
#: ulazautoupdate.rsdownloadfail
msgid "Download failed. (HTTP Errorcode %d) Try again later"
msgstr ""
#: ulazautoupdate.rsthisapplicat
msgid "This application is up-to-date"
msgstr ""
#: ulazautoupdate.rsvewversionsh
msgid "Vew version %s has downloaded. Click OK to update now."
msgstr ""

169
components/lazautoupdate/latest_stable/uappisrunning.pas Normal file
View File

@ -0,0 +1,169 @@
unit uappisrunning;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,LazUTF8,LazFileUtils,FileUtil
{$IFDEF WINDOWS}, Windows, JwaTlHelp32{$ENDIF}
{$IFDEF LINUX},process{$ENDIF};
// JwaTlHelp32 is in fpc\packages\winunits-jedi\src\jwatlhelp32.pas
// Returns TRUE if EXEName is running under Windows or Linux
// Don't pass an .exe extension to Linux!
function AppIsRunning(const ExeName: string):Boolean;
procedure KillApp(const ExeName: string);
Function GetUserName:String;
implementation
// These functions return Zero if app is NOT running
// Override them if you have a better implementation
{$IFDEF WINDOWS}
function WindowsGetUserName: string;
var
nsize: DWORD;
sz: ansistring;
begin
Result := 'unknown';
nsize := 255;
SetLength(sz, nsize);
windows.GetUsername(PChar(sz), nsize);
SetLength(sz, nsize);
Result := Trim(sz);
end;
function WindowsAppIsRunning(const ExeName: string): integer;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := 0;
while integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeName))) then
begin
Inc(Result);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
Procedure KillWindowsApp(const ExeName:String);
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
AHandle: THandle;
ID: dword;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeName))) then
begin
ID:=FProcessEntry32.th32ProcessID;
AHandle := OpenProcess(PROCESS_ALL_ACCESS,False,ID); //uses windows
TerminateProcess(AHandle,255);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
{$ENDIF}
{$IFDEF LINUX}
function LinuxGetUserName: string;
begin
Result:=GetEnvironmentVariableUTF8('USER');
end;
function LinuxAppIsRunning(const ExeName: string): integer;
var
t: TProcess;
s: TStringList;
begin
Result := 0;
t := tprocess.Create(nil);
t.CommandLine := 'ps -C ' + ExeName;
t.Options := [poUsePipes, poWaitonexit];
try
t.Execute;
s := TStringList.Create;
try
s.LoadFromStream(t.Output);
Result := Pos(ExeName, s.Text);
finally
s.Free;
end;
finally
t.Free;
end;
end;
procedure KillLinuxApp(const ExeName: string);
// killall -9 processname
// or pidof EXEName gives PID then kill PID
var
t: TProcess;
s: TStringList;
begin
t := tprocess.Create(nil);
t.CommandLine := 'killall -9 ' + ExeName;
t.Options := [poUsePipes, poWaitonexit];
try
t.Execute;
{
s := TStringList.Create;
try
s.LoadFromStream(t.Output);
Result := Pos(ExeName, s.Text);
finally
s.Free;
end;
}
finally
t.Free;
end;
end;
{$ENDIF}
Function GetUserName:String;
begin
{$IFDEF WINDOWS}
Result:=WindowsGetUserName;
{$ENDIF}
{$IFDEF LINUX}
Result:=LinuxGetUserName;
{$ENDIF}
end;
procedure KillApp(const ExeName: string);
begin
{$IFDEF WINDOWS}
KillWindowsApp(ExeName);
{$ENDIF}
{$IFDEF LINUX}
KillLinuxApp(ExeName);
{$ENDIF}
end;
function AppIsRunning(const ExeName: string):Boolean;
begin
{$IFDEF WINDOWS}
Result:=(WindowsAppIsRunning(ExeName) > 0);
{$ENDIF}
{$IFDEF LINUX}
Result:=(LinuxAppIsRunning(ExeName) > 0);
{$ENDIF}
end;
end.

2213
components/lazautoupdate/latest_stable/ulazautoupdate.pas Normal file
View File

File diff suppressed because it is too large Load Diff

258
components/lazautoupdate/latest_stable/versionsupport.pas Normal file
View File

@ -0,0 +1,258 @@
Unit VersionSupport;
{$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 VersionSupport - 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
*)
Uses
Classes, SysUtils;
Function GetFileVersion: String;
Function GetProductVersion: String;
Function GetCompiledDate: String;
Function GetCompilerInfo: String;
Function GetTargetInfo: String;
Function GetOS: String;
Function GetResourceStrings(oStringList : TStringList) : Boolean;
Function GetLCLVersion: String;
function GetWidgetSet: string;
Const
WIDGETSET_GTK = 'GTK widget set';
WIDGETSET_GTK2 = 'GTK 2 widget set';
WIDGETSET_WIN = 'Win32/Win64 widget set';
WIDGETSET_WINCE = 'WinCE widget set';
WIDGETSET_CARBON = 'Carbon widget set';
WIDGETSET_QT = 'QT widget set';
WIDGETSET_fpGUI = 'fpGUI widget set';
WIDGETSET_OTHER = 'Other gui';
Implementation
Uses
resource, versiontypes, versionresource, LCLVersion, InterfaceBase;
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
case WidgetSet.LCLPlatform of
lpGtk: Result := WIDGETSET_GTK;
lpGtk2: Result := WIDGETSET_GTK2;
lpWin32: Result := WIDGETSET_WIN;
lpWinCE: Result := WIDGETSET_WINCE;
lpCarbon:Result := WIDGETSET_CARBON;
lpQT: Result := WIDGETSET_QT;
lpfpGUI: Result := WIDGETSET_fpGUI;
else
Result:=WIDGETSET_OTHER;
end;
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 GetProductVersion: String;
Begin
CreateInfo;
If FInfo.BuildInfoAvailable Then
Result := ProductVersionToString(FInfo.FixedInfo.ProductVersion)
Else
Result := 'No build information available';
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, PChar(PtrInt(ResID)), 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.