babaev-an/lasarus_compotents
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Стартовый пул

Browse Source
This commit is contained in:
Александр Бабаев
2024-04-02 08:46:59 +03:00
parent fd57fffd3a
commit 3bb34d000b
5591 changed files with 3291734 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
splashabout_component/exampleapp/bitmapmaskmono.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 38 KiB

BIN
splashabout_component/exampleapp/cockroach.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 29 KiB

BIN
splashabout_component/exampleapp/cockroachmask.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 35 KiB

BIN
splashabout_component/exampleapp/golfballs.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 68 KiB

BIN
splashabout_component/exampleapp/golfballsmask.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 52 KiB

BIN
splashabout_component/exampleapp/golfml.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 364 KiB

15
splashabout_component/exampleapp/license.txt Normal file
View File

@@ -0,0 +1,15 @@
This is a custom license text file which must be
called 'license.txt' and be in the same folder as the executable.
You can put any text you like in here.
Certain text (without the spaces) is replaced automatically by the value of a property.
All instances of < name of author > are replaced with the Author property
All instances of < contact > are replaced with the SupportContact property
All instances of < copyright holders > are replaced with the Copyright property
All instances of < year > are replaced with the current date
Read the licence.txt included with the example application for details.
Set the properties to see the example below:
Author: <name of author>
Copyright: <copyright holders>
Support : <contact>
Released: <year>
(c)<year> by <copyright holders>

12
splashabout_component/exampleapp/linux/ppas.sh Normal file
View File

@@ -0,0 +1,12 @@
#!/bin/sh
DoExitAsm ()
{ echo "An error occurred while assembling $1"; exit 1; }
DoExitLink ()
{ echo "An error occurred while linking $1"; exit 1; }
echo Linking project1
OFS=$IFS
IFS="
"
/usr/bin/ld -b elf32-i386 -m elf_i386 --dynamic-linker=/lib/ld-linux.so.2 -L. -o project1 link.res
if [ $? != 0 ]; then DoExitLink project1; fi
IFS=$OFS

BIN
splashabout_component/exampleapp/linux/project1.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 56 KiB

137
splashabout_component/exampleapp/linux/project1.lpi Normal file
View File

@@ -0,0 +1,137 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<MainUnit Value="0"/>
<Title Value="Application Title"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
<Icon Value="0"/>
<ActiveWindowIndexAtStart Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<UseVersionInfo Value="True"/>
<MajorVersionNr Value="1"/>
<BuildNr Value="1"/>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1" Active="Default">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="splashabout"/>
<MinVersion Major="1" Minor="3" Build="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
<UsageCount Value="20"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
<IsVisibleTab Value="True"/>
<EditorIndex Value="0"/>
<WindowIndex Value="0"/>
<TopLine Value="1"/>
<CursorPos X="17" Y="40"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
<LoadedDesigner Value="True"/>
</Unit1>
<Unit2>
<Filename Value="../../usplashabout.pas"/>
<UnitName Value="usplashabout"/>
<EditorIndex Value="1"/>
<WindowIndex Value="0"/>
<TopLine Value="488"/>
<CursorPos X="31" Y="499"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2>
</Units>
<JumpHistory Count="5" HistoryIndex="4">
<Position1>
<Filename Value="unit1.pas"/>
<Caret Line="33" Column="18" TopLine="1"/>
</Position1>
<Position2>
<Filename Value="unit1.pas"/>
<Caret Line="9" Column="59" TopLine="1"/>
</Position2>
<Position3>
<Filename Value="unit1.pas"/>
<Caret Line="39" Column="17" TopLine="1"/>
</Position3>
<Position4>
<Filename Value="unit1.pas"/>
<Caret Line="40" Column="17" TopLine="1"/>
</Position4>
<Position5>
<Filename Value="unit1.pas"/>
<Caret Line="39" Column="17" TopLine="1"/>
</Position5>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="9"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<UseMsgFile Value="True"/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
splashabout_component/exampleapp/linux/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, splashabout
{ you can add units after this };
{$R *.res}
begin
Application.Title:='Application Title';
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

50
splashabout_component/exampleapp/linux/unit1.lfm Normal file
View File

@@ -0,0 +1,50 @@
object Form1: TForm1
Left = 423
Height = 129
Top = 317
Width = 193
BorderStyle = bsDialog
Caption = 'Form Caption'
ClientHeight = 129
ClientWidth = 193
OnCreate = FormCreate
Position = poDesktopCenter
LCLVersion = '0.9.30'
object Button1: TButton
Left = 16
Height = 25
Top = 24
Width = 75
Caption = 'About'
OnClick = Button1Click
TabOrder = 0
end
object Button2: TButton
Left = 104
Height = 25
Top = 24
Width = 75
Caption = 'Splash'
OnClick = Button2Click
TabOrder = 1
end
object BitBtn1: TBitBtn
Left = 64
Height = 30
Top = 72
Width = 75
Caption = '&Close'
Kind = bkClose
TabOrder = 2
end
object SplashAbout1: TSplashAbout
Font.Height = -13
UserTitle = 'My Application'
ShowDescription = False
FormSplashHeight = 280
ShowCreditButton = True
CreditsTextfileName = 'credits.txt'
left = 31
top = 73
end
end

55
splashabout_component/exampleapp/linux/unit1.pas Normal file
View File

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

BIN
splashabout_component/exampleapp/project1.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

192
splashabout_component/exampleapp/project1.lpi Normal file
View File

@@ -0,0 +1,192 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="Application Title"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
<UIAccess Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<UseVersionInfo Value="True"/>
<AutoIncrementBuild Value="True"/>
<MajorVersionNr Value="1"/>
<MinorVersionNr Value="2"/>
<BuildNr Value="8"/>
<StringTable CompanyName="by minesadorada@charcodelvalle.com" FileDescription="Example application to demonstrate SplashAbout component" LegalCopyright="LGPL license" ProductVersion="Product"/>
</VersionInfo>
<BuildModes Count="3">
<Item1 Name="Default" Default="True"/>
<Item2 Name="Debug">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="."/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<IncludeAssertionCode Value="True"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
<OverflowChecks Value="True"/>
<StackChecks Value="True"/>
</Checks>
<TargetCPU Value="i386"/>
<TargetOS Value="win32"/>
</CodeGeneration>
<Linking>
<Debugging>
<UseHeaptrc Value="True"/>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item2>
<Item3 Name="Release">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="."/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<LinkSmart Value="True"/>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item3>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="\usr\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="4">
<Item1>
<PackageName Value="LazControls"/>
</Item1>
<Item2>
<PackageName Value="scrolltext"/>
</Item2>
<Item3>
<PackageName Value="splashabout"/>
</Item3>
<Item4>
<PackageName Value="LCL"/>
</Item4>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="project1"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
<Unit2>
<Filename Value="ustringlisteditor.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="frm_StringListEditor"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="uStringListEditor"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="."/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<TargetCPU Value="i386"/>
<TargetOS Value="win32"/>
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

22
splashabout_component/exampleapp/project1.lpr Normal file
View File

@@ -0,0 +1,22 @@
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1, lazcontrols, uStringListEditor;
{$R *.res}
begin
Application.Title:='Application Title';
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.CreateForm(Tfrm_StringListEditor, frm_StringListEditor);
Application.Run;
end.

66
splashabout_component/exampleapp/readme.txt Normal file
View File

@@ -0,0 +1,66 @@
==SplashAbout Properties Tester==
Once splashabout has been installed on your component palette, then project1 should compile in windows and linux.
Note: the compiler messages 'Warning: Symbol x is not portable' are not errors.
It is because the shaped 'splash' screen features are unavailable outside the
Windows environment, and the corresponding properties are tagged as such.
I have included some sample graphic files to demonstrate the external file options
cockroach.bmp/jpg, golfballs.bmp/jpg and sunflower.bmp/jpg are
MaskColorImage and MaskMonoImage pairs
IMPORTANT: if you choose to specify external files, then you
MUST deploy them with your executable in the same folder
If you choose Graphics=saResources (default) then no external files are required.
Open license.txt to see how to write a user-defined license.
Try changing the TitleStyle, Graphics and MaskType properties to experiment
==If you are reading this via the [Help] button in the SplashAbout properties tester Application==
The SplashAbout tester displays all the current properties for the loaded SplashAbout1 component.
All changes you make will only last whilst the app is open.
If you want the app to load with your own property values, then open
up the mainform (Unit1) of the app and click the SplashAbout component
in order to make permanent changes via the Object Inspector.
The purpose of the 'SplashAbout properties tester' is so that you can
experiment with the many properties of SplashAbout, testing
(via the [Test Splash] and [Test About] buttons) until you are
familiar with configuring the component.
Change one property at a time, than click the [Test Splash] and [Test About]
buttons to see the effect of your changes. Remember to test the [Credits]
and [License] buttons on the About dialog as well.
You can also use it as a prototyper for your own
application's Splash and About screens.
If you choose to edit 'license.txt' and clear it's contents before saving it,
then the original 'license.txt' will be backed up to 'license.txt.bak'
Thus, you can restore the original example if you wish at a later date.
To make a MaskMonoImage
======================
In an image editor (I used Paint Shop Pro) reduce the palette to 2 colours and save as a BMP file (Not RLEncoded)
Black=transparent to the desktop
White=transparent to the splash window background (can be a solid colour or a BackgroundImage or a MaskPImage)
Note: If a MaskColorImage is specified, it hides the BackGroundImage in the splash screen (but not the About dialog)
and also supresses the text display on the splash screen (see below)
To make a MaskMonoImage and MaskColorImage pair
==========================================
For the most dramatic effect, find an strong image which fits fully within a square window
without touching the edges (compare images 'cockroach' and 'golfballs' with 'sunflower')
Using a paint program isolate the image on a white background and save it as a jpg
Using a paint program, make the image pure black, reduce the colour pallete to 2 and save it as a BMP
Set the properties:
MaskType=saUserImage
Graphics=saResources
BitmapMaskColor=your jpg file
BitmapMaskMono=your bmp file
If all this looks complicated - just experiment with the properties and images provided!

BIN
splashabout_component/exampleapp/ski.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 56 KiB

BIN
splashabout_component/exampleapp/splash.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 21 KiB

BIN
splashabout_component/exampleapp/splash1.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 21 KiB

BIN
splashabout_component/exampleapp/sunflower.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 55 KiB

BIN
splashabout_component/exampleapp/sunflowermask.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 22 KiB

46778
splashabout_component/exampleapp/unit1.lfm Normal file
View File

File diff suppressed because it is too large Load Diff

729
splashabout_component/exampleapp/unit1.pas Normal file
View File

@@ -0,0 +1,729 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code 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 *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
= Example application for the SplashAbout component
= Gordon Bamber
= minesadorada@gmail.com
= June 2014
=
= Use this app to experiment with different Splash screens and About dialogs
=
= Note: All external files MUST be deployed with your application in the same folder
}
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, usplashabout, Forms, Controls, FileUtil, Graphics, Dialogs,
Buttons, ExtCtrls, StdCtrls, ExtDlgs, Menus, Lresources,uStringListEditor;
type
{ TForm1 }
TForm1 = class(TForm)
cmd_Help: TBitBtn;
cmd_EditLicenseTxt: TButton;
cmd_Description: TButton;
cmd_EditCreditsTxt: TButton;
cmd_SetFont: TButton;
cmd_CreditsLines: TButton;
cmd_SetAuthor: TButton;
cmd_SetOrganisation: TButton;
cmd_SetSupportContact: TButton;
cmd_SetUserTitle: TButton;
CheckGroupUseExternalFile: TCheckGroup;
cmd_BitmapBackground: TButton;
cmd_Icon: TButton;
cmd_BitmapMaskMono: TButton;
cmd_BitmapMaskColor: TButton;
cmd_TestAbout: TBitBtn;
cmd_TestSplash: TBitBtn;
cmd_Close: TBitBtn;
CheckGroupShow: TCheckGroup;
edt_SplashHeight: TLabeledEdit;
edt_AboutHeight: TLabeledEdit;
edt_AboutWidth: TLabeledEdit;
CreditsGroupBox: TGroupBox;
FontDialog1: TFontDialog;
FontGroupBox: TGroupBox;
MainMenu1: TMainMenu;
mnu_helpAbout: TMenuItem;
mnu_fileHelp: TMenuItem;
mnu_fileClose: TMenuItem;
mnu_file: TMenuItem;
ResizeGraphicRadioGroup: TRadioGroup;
SetLicenseVarsGroupBox: TGroupBox;
GroupBoxBitmaps: TGroupBox;
GroupBoxTitleStyle: TGroupBox;
GroupBoxSplashDialog: TGroupBox;
edt_SplashWidth: TLabeledEdit;
GroupBoxAboutDialog: TGroupBox;
MaskTypeRadioGroup: TRadioGroup;
GraphicsRadioGroup: TRadioGroup;
dlg_OpenBitmap: TOpenPictureDialog;
LicenseFileRadioGroup: TRadioGroup;
txt_Top: TStaticText;
TitleStyleRadioGroup: TRadioGroup;
SplashAlignRadioGroup: TRadioGroup;
SplashAbout1: TSplashAbout;
AboutAlignRadioGroup: TRadioGroup;
procedure AboutAlignRadioGroupSelectionChanged(Sender: TObject);
procedure CheckGroupUseExternalFileClick(Sender: TObject);
procedure CheckGroupUseExternalFileItemClick(Sender: TObject; Index: integer);
procedure cmd_BitmapBackgroundClick(Sender: TObject);
procedure cmd_CreditsLinesClick(Sender: TObject);
procedure cmd_DescriptionClick(Sender: TObject);
procedure cmd_EditCreditsTxtClick(Sender: TObject);
procedure cmd_EditLicenseTxtClick(Sender: TObject);
procedure cmd_HelpClick(Sender: TObject);
procedure cmd_IconClick(Sender: TObject);
procedure cmd_BitmapMaskColorClick(Sender: TObject);
procedure cmd_BitmapMaskMonoClick(Sender: TObject);
procedure cmd_SetAuthorClick(Sender: TObject);
procedure cmd_SetFontClick(Sender: TObject);
procedure cmd_SetOrganisationClick(Sender: TObject);
procedure cmd_SetSupportContactClick(Sender: TObject);
procedure cmd_SetUserTitleClick(Sender: TObject);
procedure cmd_TestAboutClick(Sender: TObject);
procedure cmd_TestSplashClick(Sender: TObject);
procedure CheckGroupShowItemClick(Sender: TObject; Index: integer);
procedure edt_AboutHeightEditingDone(Sender: TObject);
procedure edt_AboutWidthEditingDone(Sender: TObject);
procedure edt_SplashHeightEditingDone(Sender: TObject);
procedure edt_SplashWidthEditingDone(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure GraphicsRadioGroupSelectionChanged(Sender: TObject);
procedure LicenseFileRadioGroupSelectionChanged(Sender: TObject);
procedure MaskTypeRadioGroupSelectionChanged(Sender: TObject);
procedure mnu_helpAboutClick(Sender: TObject);
procedure ResizeGraphicRadioGroupSelectionChanged(Sender: TObject);
procedure SplashAlignRadioGroupSelectionChanged(Sender: TObject);
procedure TitleStyleRadioGroupSelectionChanged(Sender: TObject);
private
{ private declarations }
var
i: integer; //(Used in TryStrToInt routines)
sz: string; // used in InputQuery routines
ABitMap: TBitmap;
function FetchBitmap(const AFileFilter: string): boolean;
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.cmd_TestAboutClick(Sender: TObject);
begin
SplashAbout1.ShowAbout;
end;
procedure TForm1.AboutAlignRadioGroupSelectionChanged(Sender: TObject);
begin
SplashAbout1.FormAboutTextAlign := TAlignment(AboutAlignRadioGroup.ItemIndex);
end;
procedure TForm1.CheckGroupUseExternalFileClick(Sender: TObject);
begin
end;
procedure TForm1.CheckGroupUseExternalFileItemClick(Sender: TObject; Index: integer);
const
C_NOBITMAP = 'There is no graphic currently assigned. Click the button to assign one';
C_CLEAR_RESOURCE = 'Clear the graphic resource?';
// There's probably a more elegant way to do this...
begin
if (SplashAbout1.Graphics = saExternalFiles) then
// Set the ExternalFileOptions flags
begin
case Index of
0: if CheckGroupUseExternalFile.Checked[Index] then
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions + [saExternalBackground]
else
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions - [saExternalBackground];
1: if CheckGroupUseExternalFile.Checked[Index] then
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions + [saExternalMaskMonoImage]
else
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions - [saExternalMaskMonoImage];
2: if CheckGroupUseExternalFile.Checked[Index] then
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions + [saExternalMaskColorImage]
else
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions - [saExternalMaskColorImage];
3: if CheckGroupUseExternalFile.Checked[Index] then
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions + [saExternalIcon]
else
SplashAbout1.ExternalFileOptions :=
SplashAbout1.ExternalFileOptions - [saExternalIcon];
end;
end
else
begin
// Graphics=saResources so a different set of actions...
case Index of
0: if CheckGroupUseExternalFile.Checked[Index] then
begin
if (SplashAbout1.BitmapBackGround.Width = 0) then
begin
ShowMessage(C_NOBITMAP);
CheckGroupUseExternalFile.Checked[Index] := False;
end;
end
else
begin
if (SplashAbout1.BitmapBackGround.Width > 0) then
if MessageDlg(C_CLEAR_RESOURCE, mtConfirmation,
[mbYes, mbAbort], 0) = mrYes then
SplashAbout1.BitmapBackGround := nil
else
CheckGroupUseExternalFile.Checked[Index] := True;
end;
1: if CheckGroupUseExternalFile.Checked[Index] then
begin
if (SplashAbout1.BitmapMaskMono.Width = 0) then
begin
ShowMessage(C_NOBITMAP);
CheckGroupUseExternalFile.Checked[Index] := False;
end;
end
else
begin
if (SplashAbout1.BitmapMaskMono.Width > 0) then
if MessageDlg(C_CLEAR_RESOURCE, mtConfirmation,
[mbYes, mbAbort], 0) = mrYes then
SplashAbout1.BitmapMaskMono := nil
else
CheckGroupUseExternalFile.Checked[Index] := True;
end;
2: if CheckGroupUseExternalFile.Checked[Index] then
begin
if (SplashAbout1.BitmapMaskColor.Width = 0) then
begin
ShowMessage(C_NOBITMAP);
CheckGroupUseExternalFile.Checked[Index] := False;
end;
end
else
begin
if (SplashAbout1.BitmapMaskColor.Width > 0) then
if MessageDlg(C_CLEAR_RESOURCE, mtConfirmation,
[mbYes, mbAbort], 0) = mrYes then
SplashAbout1.BitmapMaskColor := nil
else
CheckGroupUseExternalFile.Checked[Index] := True;
end;
3: if CheckGroupUseExternalFile.Checked[Index]=False then
CheckGroupUseExternalFile.Checked[Index] := True;
end;
end;
end;
function TForm1.FetchBitmap(const AFileFilter: string): boolean;
// Open a graphics dialog with specified filter
// Use LoadFromFile to assign to a graphic type
// convert various graphic types into TBitmap and
// assign it to the private var ABitmap
// Used to assign to TBitmap properties of SplashAbout
var
MyBitMap: TBitMap;
MyJPG: TJpegImage;
MyTiff: TTiffImage;
MyGif: TGifImage;
MyPNG: TPortableNetworkGraphic;
szTemp: string;
begin
try
MyBitmap := TBitMap.Create;
MyJPG := TJpegImage.Create;
MyTiff := TTiffImage.Create;
// Turn off pointless compiler warning about creating a TGifImage
{$WARNINGS OFF}
MyGif := TGifImage.Create;
{$WARNINGS ON}
MyPNG := TPortableNetworkGraphic.Create;
szTemp := dlg_OpenBitmap.Filter;
Result := False;
dlg_OpenBitmap.Title := 'Fetch graphic';
dlg_OpenBitmap.Filter := 'Graphic|' + AFileFilter;
if dlg_OpenBitmap.Execute then
begin
if CompareFileExt(dlg_OpenBitmap.Filename, '.jpg', False) = 0 then
begin
MyJPG.LoadFromFile(dlg_OpenBitmap.Filename);
ABitMap.Assign(MyJPG);
end;
if CompareFileExt(dlg_OpenBitmap.Filename, '.bmp', False) = 0 then
begin
MyBitMap.LoadFromFile(dlg_OpenBitmap.Filename);
ABitMap.Assign(MyBitMap);
end;
if CompareFileExt(dlg_OpenBitmap.Filename, '.tif', False) = 0 then
begin
MyTiff.LoadFromFile(dlg_OpenBitmap.Filename);
ABitMap.Assign(MyTiff);
end;
if CompareFileExt(dlg_OpenBitmap.Filename, '.png', False) = 0 then
begin
MyPNG.LoadFromFile(dlg_OpenBitmap.Filename);
ABitMap.Assign(MyPNG);
end;
if CompareFileExt(dlg_OpenBitmap.Filename, '.gif', False) = 0 then
begin
MyGif.LoadFromFile(dlg_OpenBitmap.Filename);
ABitMap.Assign(MyGif);
end;
Result := True;
end;
finally
dlg_OpenBitmap.Filter := szTemp;
MyPNG.Free;
MyGif.Free;
MyTiff.Free;
MyJPG.Free;
MyBitmap.Free;
end;
end;
procedure TForm1.cmd_BitmapBackgroundClick(Sender: TObject);
begin
if (SplashAbout1.Graphics = saResources) then
begin
if FetchBitmap('*.bmp;*.jpg;*.tif;*.png;*.gif;') then
SplashAbout1.BitmapBackGround.Assign(ABitMap);
end
else
begin
dlg_OpenBitmap.Title := 'Fetch external graphic file';
dlg_OpenBitmap.Filename := SplashAbout1.ExternalFileBackgroundImage;
if dlg_OpenBitmap.Execute then
begin
SplashAbout1.ExternalFileBackgroundImage := dlg_OpenBitmap.Filename;
if (GraphicsRadioGroup.ItemIndex <> 0) then;
end;
end;
end;
procedure TForm1.cmd_CreditsLinesClick(Sender: TObject);
begin
with frm_StringListEditor do
begin
Caption := 'Edit CreditLines';
StringListEditorMemo.Clear;
StringListEditorMemo.Lines.Assign(SplashAbout1.Creditlines);
ShowModal;
SplashAbout1.Creditlines.Assign(StringListEditorMemo.Lines);
end;
end;
procedure TForm1.cmd_DescriptionClick(Sender: TObject);
begin
with frm_StringListEditor do
begin
Caption := 'Edit Description';
StringListEditorMemo.Clear;
StringListEditorMemo.Lines.Assign(SplashAbout1.Description);
ShowModal;
SplashAbout1.Description.Assign(StringListEditorMemo.Lines);
end;
end;
procedure TForm1.cmd_EditCreditsTxtClick(Sender: TObject);
begin
// Warn user
if (not FileExists(SplashAbout1.CreditsTextFilename)) then
ShowMessageFmt(
'Note that if you create and populate ''%s'' it will be used in preference to the CreditLines stringlist',
[SplashAbout1.CreditsTextFilename]);
with frm_StringListEditor do
begin
StringListEditorMemo.Clear;
// Load from file?
if FileExists(SplashAbout1.CreditsTextFilename) then
StringListEditorMemo.Lines.LoadFromFile(SplashAbout1.CreditsTextFilename);
// Show the editor
ShowModal;
// Only (create) and Save if there is text in the Memo
// Note this overwrites any existing file
if StringListEditorMemo.Lines.Count > 0 then
StringListEditorMemo.Lines.SaveToFile(SplashAbout1.CreditsTextFilename)
else
// Clearing the text and saving deletes any existing file
// No point in saving an empty file
if FileExists(SplashAbout1.CreditsTextFilename) then
SysUtils.DeleteFile(SplashAbout1.CreditsTextFilename);
end;
end;
procedure TForm1.cmd_EditLicenseTxtClick(Sender: TObject);
begin
with frm_StringListEditor do
begin
StringListEditorMemo.Clear;
if FileExists('license.txt') then
StringListEditorMemo.Lines.LoadFromFile('license.txt');
ShowModal;
if StringListEditorMemo.Lines.Count > 0 then
StringListEditorMemo.Lines.SaveToFile('license.txt')
else
begin
if FileExists('license.txt') then
begin
FileUtil.CopyFile('license.txt', 'license.txt.bak');
DeleteFile('license.txt');
ShowMessage('Old ''license.txt'' has been backed up to ''license.txt.bak''');
end;
end;
end;
end;
procedure TForm1.cmd_HelpClick(Sender: TObject);
var
iPos: integer;
begin
with frm_StringListEditor do
begin
Caption := 'Help for SplashAbout tester';
StringListEditorMemo.Clear;
StringListEditorMemo.Lines.LoadFromFile('readme.txt');
// Highlight the relavent text
iPos := Pos('==If', StringListEditorMemo.Text);
StringListEditorMemo.SelStart := iPos - 1;
StringListEditorMemo.SelLength := 98;
// Show the readonly memo
StringListEditorMemo.ReadOnly := True;
ShowModal;
StringListEditorMemo.ReadOnly := False;
end;
end;
procedure TForm1.cmd_IconClick(Sender: TObject);
var
szTemp: string;
begin
Try
if (SplashAbout1.Graphics = saResources) then
begin
szTemp := dlg_OpenBitmap.Filter;
dlg_OpenBitmap.Filter := 'Icon|*.ico';
if dlg_OpenBitmap.Execute then
begin
SplashAbout1.Icon.LoadFromFile(dlg_OpenBitmap.Filename);
end;
dlg_OpenBitmap.Filter := szTemp;
end
else
begin
dlg_OpenBitmap.Filename := SplashAbout1.ExternalFileIcon;
if dlg_OpenBitmap.Execute then
begin
SplashAbout1.ExternalFileIcon := dlg_OpenBitmap.Filename;
if (GraphicsRadioGroup.ItemIndex <> 0) then
begin
GraphicsRadioGroup.ItemIndex := 0;
ShowMessage('Graphics property has been set to saExternalFiles');
end;
end;
end;
Except
on e: Exception do
ShowMessage(e.ClassName);
end;
end;
procedure TForm1.cmd_BitmapMaskColorClick(Sender: TObject);
begin
if (SplashAbout1.Graphics = saResources) then
begin
if FetchBitmap('*.bmp;*.jpg;*.tif;*.png;*.gif;') then
SplashAbout1.BitmapMaskColor.Assign(ABitMap);
end
else
begin
dlg_OpenBitmap.Filename := SplashAbout1.ExternalFileMaskColorImage;
if dlg_OpenBitmap.Execute then
begin
SplashAbout1.ExternalFileMaskColorImage := dlg_OpenBitmap.Filename;
if (GraphicsRadioGroup.ItemIndex <> 0) then
begin
GraphicsRadioGroup.ItemIndex := 0;
ShowMessage('Graphics property has been set to saExternalFiles');
end;
end;
end;
end;
procedure TForm1.cmd_BitmapMaskMonoClick(Sender: TObject);
begin
if (SplashAbout1.Graphics = saResources) then
begin
if FetchBitmap('*.bmp;') then
SplashAbout1.BitmapMaskMono.Assign(ABitMap);
end
else
begin
dlg_OpenBitmap.Filename := SplashAbout1.ExternalFileMaskMonoImage;
if dlg_OpenBitmap.Execute then
begin
SplashAbout1.ExternalFileMaskMonoImage := dlg_OpenBitmap.Filename;
if (GraphicsRadioGroup.ItemIndex <> 0) then
begin
GraphicsRadioGroup.ItemIndex := 0;
ShowMessage('Graphics property has been set to saExternalFiles');
end;
end;
end;
end;
procedure TForm1.cmd_SetAuthorClick(Sender: TObject);
begin
if InputQuery('Set the Author token', 'Current value = ' +
SplashAbout1.Author, sz) then
SplashAbout1.Author := sz;
end;
procedure TForm1.cmd_SetFontClick(Sender: TObject);
begin
{$IFDEF WINDOWS}
// Warning: 'THandle is depreciated'
{$WARNINGS OFF}
FontDialog1.Font.Name := GetFontData(cmd_SetFont.Font.Handle).Name;
{$WARNINGS ON}
{$ENDIF}
if FontDialog1.Execute then
SplashAbout1.Font.Assign(FontDialog1.Font);
end;
procedure TForm1.cmd_SetOrganisationClick(Sender: TObject);
begin
if InputQuery('Set the Organisation token', 'Current value = ' +
SplashAbout1.Organisation, sz) then
SplashAbout1.Organisation := sz;
end;
procedure TForm1.cmd_SetSupportContactClick(Sender: TObject);
begin
if InputQuery('Set the SupportContact token', 'Current value = ' +
SplashAbout1.SupportContact, sz) then
SplashAbout1.SupportContact := sz;
end;
procedure TForm1.cmd_SetUserTitleClick(Sender: TObject);
begin
if InputQuery('Set the User Title', 'Current value = ' +
SplashAbout1.UserTitle, sz) then
SplashAbout1.UserTitle := sz;
end;
procedure TForm1.cmd_TestSplashClick(Sender: TObject);
begin
SplashAbout1.ShowSplash;
end;
procedure TForm1.CheckGroupShowItemClick(Sender: TObject; Index: integer);
begin
with CheckGroupShow do
case Index of
0: SplashAbout1.ShowPoweredBy := Checked[0];
1: SplashAbout1.ShowDescription := Checked[1];
2: SplashAbout1.ShowCreditButton := Checked[2];
end;
end;
procedure TForm1.edt_AboutHeightEditingDone(Sender: TObject);
begin
if TryStrToInt(edt_AboutHeight.Text, i) then
SplashAbout1.FormAboutHeight := i
else
begin
ShowMessageFmt('%s is not a number', [edt_AboutHeight.Text]);
edt_AboutHeight.Text := IntToStr(SplashAbout1.FormAboutHeight);
end;
end;
procedure TForm1.edt_AboutWidthEditingDone(Sender: TObject);
begin
if TryStrToInt(edt_AboutWidth.Text, i) then
SplashAbout1.FormAboutWidth := i
else
begin
ShowMessageFmt('%s is not a number', [edt_AboutWidth.Text]);
edt_AboutWidth.Text := IntToStr(SplashAbout1.FormAboutWidth);
end;
end;
procedure TForm1.edt_SplashHeightEditingDone(Sender: TObject);
begin
if TryStrToInt(edt_SplashHeight.Text, i) then
SplashAbout1.FormSplashHeight := i
else
begin
ShowMessageFmt('%s is not a number', [edt_SplashHeight.Text]);
edt_SplashHeight.Text := IntToStr(SplashAbout1.FormSplashHeight);
end;
end;
procedure TForm1.edt_SplashWidthEditingDone(Sender: TObject);
begin
if TryStrToInt(edt_SplashWidth.Text, i) then
SplashAbout1.FormSplashWidth := i
else
begin
ShowMessageFmt('%s is not a number', [edt_SplashWidth.Text]);
edt_SplashWidth.Text := IntToStr(SplashAbout1.FormSplashWidth);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SplashAbout1.ShowSplash;
// Init the Example app controls
// RadioGroups (enumerated properties)
MaskTypeRadioGroup.ItemIndex := Ord(SplashAbout1.MaskType);
TitleStyleRadioGroup.ItemIndex := Ord(SplashAbout1.TitleStyle);
SplashAlignRadioGroup.ItemIndex := Ord(SplashAbout1.FormSplashTextAlign);
AboutAlignRadioGroup.ItemIndex := Ord(SplashAbout1.FormAboutTextAlign);
LicenseFileRadioGroup.ItemIndex := Ord(SplashAbout1.LicenseFile);
ResizeGraphicRadioGroup.ItemIndex := Ord(SplashAbout1.ResizeMode);
// Enumerated type with 2 items acts like booleans (!)
if SplashAbout1.Graphics = saExternalFiles then
GraphicsRadioGroup.ItemIndex := 0
else
GraphicsRadioGroup.ItemIndex := 1;
with CheckGroupShow do
// Checkboxes
begin
if SplashAbout1.ShowPoweredBy then
Checked[0] := True;
if SplashAbout1.ShowDescription then
Checked[1] := True;
if SplashAbout1.ShowCreditButton then
Checked[2] := True;
end;
with CheckGroupUseExternalFile do
begin
if saExternalBackground in SplashAbout1.ExternalFileOptions then
Checked[0] := True;
if saExternalMaskMonoImage in SplashAbout1.ExternalFileOptions then
Checked[1] := True;
if saExternalMaskColorImage in SplashAbout1.ExternalFileOptions then
Checked[2] := True;
if saExternalIcon in SplashAbout1.ExternalFileOptions then
Checked[3] := True;
end;
// Edit controls
edt_SplashWidth.Text := IntToStr(SplashAbout1.FormSplashWidth);
edt_SplashHeight.Text := IntToStr(SplashAbout1.FormSplashHeight);
edt_AboutWidth.Text := IntToStr(SplashAbout1.FormAboutWidth);
edt_AboutHeight.Text := IntToStr(SplashAbout1.FormAboutHeight);
// Buttons
cmd_EditCreditsTxt.Caption := 'Edit ' + SplashAbout1.CreditsTextfileName;
ABitmap := TBitmap.Create;
end;
procedure TForm1.GraphicsRadioGroupSelectionChanged(Sender: TObject);
Var iCount:Integer;
begin
case GraphicsRadioGroup.ItemIndex of
0: SplashAbout1.Graphics := saExternalFiles;
1: SplashAbout1.Graphics := saResources;
end;
// Reset the 'Use' checkboxes
For iCount:=0 to 3 do
CheckGroupUseExternalFile.Checked[iCount]:=True;
end;
procedure TForm1.LicenseFileRadioGroupSelectionChanged(Sender: TObject);
begin
SplashAbout1.LicenseFile := tLicenseFile(LicenseFileRadioGroup.ItemIndex);
end;
procedure TForm1.MaskTypeRadioGroupSelectionChanged(Sender: TObject);
begin
SplashAbout1.MaskType := tMaskType(MaskTypeRadioGroup.ItemIndex);
end;
procedure TForm1.mnu_helpAboutClick(Sender: TObject);
// You can set Splashabout properties via code:
Var
tempTitleStyle:TTitleStyleType;
tempTitle:String;
begin
With SplashAbout1 do
begin
tempTitleStyle:=TitleStyle;
tempTitle:=UserTitle;
TitleStyle:=saUserTitle;
UserTitle:=txt_Top.Caption;
ShowAbout;
TitleStyle:=tempTitleStyle;
UserTitle:=tempTitle;
end;
end;
procedure TForm1.ResizeGraphicRadioGroupSelectionChanged(Sender: TObject);
begin
SplashAbout1.ResizeMode:=tResizeMode(ResizeGraphicRadioGroup.ItemIndex);
end;
procedure TForm1.SplashAlignRadioGroupSelectionChanged(Sender: TObject);
begin
SplashAbout1.FormSplashTextAlign := TAlignment(SplashAlignRadioGroup.ItemIndex);
end;
procedure TForm1.TitleStyleRadioGroupSelectionChanged(Sender: TObject);
begin
SplashAbout1.TitleStyle := TTitleStyleType(TitleStyleRadioGroup.ItemIndex);
end;
// When compiling, explain the 'platform' directive on some properties
{$Hint Don't worry about the 'Warning: Symbol xxx is not portable' messages}
{$Hint The 'not portable' code is stuff that won't work outside of Windows}
{$Hint ..so I flagged it as such in the component code}
end.

47
splashabout_component/exampleapp/ustringlisteditor.lfm Normal file
View File

@@ -0,0 +1,47 @@
object frm_StringListEditor: Tfrm_StringListEditor
Left = 1028
Height = 513
Top = 327
Width = 552
BorderIcons = []
BorderStyle = bsSizeToolWin
Caption = 'frm_StringListEditor'
ClientHeight = 513
ClientWidth = 552
DefaultMonitor = dmMainForm
FormStyle = fsStayOnTop
PopupMode = pmExplicit
PopupParent = Form1.Owner
Position = poMainFormCenter
ShowInTaskBar = stNever
LCLVersion = '1.2.2.0'
object StringListEditorMemo: TMemo
Left = 0
Height = 440
Top = 0
Width = 552
Align = alTop
ScrollBars = ssAutoVertical
TabOrder = 0
end
object cmd_Close: TBitBtn
Left = 219
Height = 30
Top = 464
Width = 115
Caption = '&Close and Save'
Kind = bkClose
ModalResult = 11
TabOrder = 1
end
object cmd_ClearMemo: TBitBtn
Left = 424
Height = 30
Top = 464
Width = 107
Caption = 'Clear all text'
Kind = bkAbort
OnClick = cmd_ClearMemoClick
TabOrder = 2
end
end

40
splashabout_component/exampleapp/ustringlisteditor.pas Normal file
View File

@@ -0,0 +1,40 @@
unit uStringListEditor;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons;
type
{ Tfrm_StringListEditor }
Tfrm_StringListEditor = class(TForm)
cmd_ClearMemo: TBitBtn;
cmd_Close: TBitBtn;
StringListEditorMemo: TMemo;
procedure cmd_ClearMemoClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
frm_StringListEditor: Tfrm_StringListEditor;
implementation
{$R *.lfm}
{ Tfrm_StringListEditor }
procedure Tfrm_StringListEditor.cmd_ClearMemoClick(Sender: TObject);
begin
StringListEditorMemo.Clear;
end;
end.

BIN
splashabout_component/poweredby/graphics_resources/linux_powered_by_graphic.jpg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 13 KiB

BIN
splashabout_component/poweredby/graphics_resources/powered_by.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.8 KiB

BIN
splashabout_component/poweredby/graphics_resources/powered_by_graphic.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 49 KiB

63
splashabout_component/poweredby/poweredby.lpk Normal file
View File

@@ -0,0 +1,63 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="poweredby"/>
<AddToProjectUsesSection Value="True"/>
<Author Value="minesadorada@charcodelvalle.com"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="Method: ShowPoweredBy
Graphic shown will depend on widgetset"/>
<License Value="TPoweredby Component
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. "/>
<Version Major="1" Release="3"/>
<Files Count="1">
<Item1>
<Filename Value="upoweredby.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="uPoweredby"/>
</Item1>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

21
splashabout_component/poweredby/poweredby.pas Normal file
View File

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

BIN
splashabout_component/poweredby/poweredby_component.zip Normal file
View File

Binary file not shown.

296
splashabout_component/poweredby/upoweredby.pas Normal file
View File

@@ -0,0 +1,296 @@
{ TPoweredby Component
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 uPoweredby;
{$mode objfpc}{$H+}
interface
uses
Classes, Controls, Dialogs, Forms, Graphics, LResources, SysUtils,
ExtCtrls, InterfaceBase, LCLType,LCLVersion;
const
C_VERSIONSTRING = '1.0.3.0';
C_WIDGETSET_GTK = 'GTK widget set';
C_WIDGETSET_GTK2 = 'GTK 2 widget set';
C_WIDGETSET_GTK3 = 'GTK 3 widget set';
C_WIDGETSET_WIN = 'Win32/Win64 widget set';
C_WIDGETSET_WINCE = 'WinCE widget set';
C_WIDGETSET_CARBON = 'Carbon widget set';
C_WIDGETSET_QT = 'QT widget set';
C_WIDGETSET_fpGUI = 'fpGUI widget set';
C_WIDGETSET_COCOA = 'Cocoa widget set';
C_WIDGETSET_CUSTOM = 'Custom drawn widget set';
C_WIDGETSET_OTHER = 'Other gui';
type
TPoweredby = class(TComponent)
private
{ Private declarations }
fPoweredByForm: TForm;
fVersionString: string;
fDelayMilliseconds: integer;
fFadeInMilliseconds: integer;
fShowOnlyOnce,fAlreadyShown:Boolean;
// Used by Timer to close the PoweredBy form
procedure ClosePoweredByForm(Sender: TObject);
// Windows only!
procedure FadeInPoweredBy(Sender: TObject);
procedure SetDelayMilliSeconds(AValue: integer);
function GetWidgetSetString: string;
Function GetFPCTargetInfoString: String;
Function GetInfoLCLVersion:String;
Function GetInfoFPCVersion:String;
protected
{ Protected declarations }
public
{ Public declarations }
// Call the method 'ShowPoweredByForm' to show the shaped window
procedure ShowPoweredByForm;
// Called when component is dropped onto a form
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
// Minimum delay=1000msec; Maximum delay=10000msec. Fade-in time is automatically adjusted
property DelayMilliSecs: integer read fDelayMilliSeconds write SetDelayMilliSeconds default 1000;
// Call the method 'ShowPoweredByForm' to show the shaped window
property Version: string read fVersionString;
// Reports the current WidgetSet
property InfoWidgetSet: string read GetWidgetSetString;
// Reports your current Environment
property InfoFPCTarget:String read GetFPCTargetInfoString;
// Reports your current Environment
property InfoFPCVersion:String read GetInfoFPCVersion;
// Reports your current Environment
property InfoLCLVersion:String read GetInfoLCLVersion;
// Useful if you have ShowPoweredByForm in your TForm.Activate() method
property ShowOnlyOnce:boolean read fShowOnlyOnce write fShowOnlyOnce default false;
end;
procedure Register;
implementation
procedure Register;
begin
{$I upoweredby_icon.lrs}
RegisterComponents('Additional', [TPoweredby]);
end;
constructor TPoweredby.Create(AOwner: TComponent);
// Initialise private vars
begin
inherited Create(AOwner);
fVersionString := C_VERSIONSTRING;
fDelayMilliseconds := 1000;
fFadeInMilliseconds := 20;
fAlreadyShown:=False;
fShowOnlyOnce:=False;
end;
Function TPoweredby.GetInfoLCLVersion:String;
begin
result:=lcl_version;
end;
Function TPoweredby.GetInfoFPCVersion:String;
begin
Result:={$I %FPCVERSION%};
end;
Function TPoweredby.GetFPCTargetInfoString: String;
begin
Result := {$I %FPCTARGETCPU%}+' - '+{$I %FPCTARGETOS%};
end;
function priv_GetWidgetSetString: string;
// This code cannot be a method of TPoweredBy
begin
case WidgetSet.LCLPlatform of
lpGtk: Result := C_WIDGETSET_GTK;
lpGtk2: Result := C_WIDGETSET_GTK2;
lpWin32: Result := C_WIDGETSET_WIN;
lpWinCE: Result := C_WIDGETSET_WINCE;
lpCarbon: Result := C_WIDGETSET_CARBON;
lpCocoa: Result := C_WIDGETSET_COCOA;
lpQT: Result := C_WIDGETSET_QT;
lpfpGUI: Result := C_WIDGETSET_fpGUI;
// When were these first included in InterfaceBase?
{$IFDEF FPC_FULLVERSION>24200}
lpGtk3: Result := C_WIDGETSET_GTK3;
lpCustomDrawn: Result := C_WIDGETSET_CUSTOM;
{$ENDIF}
else
Result := C_WIDGETSET_OTHER;
end;
end;
function TPoweredby.GetWidgetSetString: string;
begin
Result := priv_GetWidgetSetString;
end;
procedure TPoweredby.SetDelayMilliSeconds(AValue: integer);
begin
if ((fDelayMilliSeconds <> AValue) and (AValue > 0) and (AValue < 11000)) then
begin
fDelayMilliseconds := AValue;
fFadeInMilliseconds := (AValue div 1000) * 20;
end;
end;
procedure TPoweredby.ClosePoweredByForm(Sender: TObject);
// Called by Timer event in ShowPoweredByForm to close Modal window
// Also the image OnClick event
begin
fPoweredByForm.Close;
end;
procedure TPoweredby.FadeInPoweredBy(Sender: TObject);
// Use Alphablend property of TForm
begin
if (fPoweredByForm.AlphaBlendValue < 245) then
fPoweredByForm.AlphaBlendValue := fPoweredByForm.AlphaBlendValue + 10;
end;
function CanShowRoundedGraphic: boolean;
{
Check the current WidgetSet, and add to the list that can show the rounded graphic
Choices are:
lpGtk,
lpGtk2,
lpGtk3,
lpWin32,
lpWinCE,
lpCarbon,
lpQT,
lpfpGUI,
lpNoGUI,
lpCocoa,
lpCustomDrawn
}
begin
case WidgetSet.LCLPlatform of
lpWin32, lpQT: Result := True;
else
Result := False;
end;
end;
procedure TPoweredby.ShowPoweredByForm;
// Graphics are in masks.lrs
// 1 ) Constructs a new TForm with an image control
// 2 ) Uses the 'SetShape' method of the form canvas to create a transparent mask
// 3 ) Paints the Timage over it with a color image
// 4 ) Sets a timer to fade it in using the Alphablend property
// 5 ) Sets another timer to close the form
// Note: Windows can fade in a shaped transparent screen
// But some widgetsets (GTK,Carbon) cannot
var
img_Background: TImage;
MyBitmap: TBitMap;
DelayTimer: TTimer;
FadeInTimer: TTImer;
begin
// Respect the ShowOnlyOnce property setting
If ((fShowOnlyOnce=TRUE) AND (fAlreadyShown=TRUE)) then Exit;
// Try..Finally so we can be sure resources are Freed
try
try
// Create controls
fPoweredByForm := TForm.Create(nil);
fPoweredByForm.AlphaBlend := True;
fPoweredByForm.AlphaBlendValue := 0;
img_background := TImage.Create(fPoweredByForm);
// Bitmap mask - Load from resource
MyBitmap := TBitMap.Create;
MyBitmap.LoadFromLazarusResource('powered_by_mask');
// Delay Timer
Delaytimer := TTimer.Create(fPoweredByForm);
delaytimer.Interval := fDelayMilliseconds;
delaytimer.OnTimer := @ClosePoweredByForm;
FadeInTimer := TTimer.Create(fPoweredByForm);
FadeInTimer.Interval := fFadeInMilliseconds;
FadeInTimer.OnTimer := @FadeInPoweredBy;
// BackGround image - load from resource
with img_background do
begin
Align := alClient;
Stretch := True;
Parent := fPoweredByForm;
if CanShowRoundedGraphic then
Picture.LoadFromLazarusResource('win_powered_by')
else
Picture.LoadFromLazarusResource('powered_by');
OnClick := @ClosePoweredByForm;
SendToBack;
end;
// Set form properties
with fPoweredByForm do
begin
position := poScreenCenter;
borderstyle := bsnone;
formstyle := fsSystemStayOnTop;
OnClick := @ClosePoweredByForm;
color := clBlack;
Height := MyBitmap.Height;
Width := MyBitMap.Width;
if CanShowRoundedGraphic then
begin
MyBitMap.Transparent := True;
MyBitMap.TransparentColor := clBlack;
Canvas.Draw(0, 0, MyBitMap);
// raises Floating Point Error in linux GTK (!??)
SetShape(MyBitMap);
end
else
begin
// If square graphic, then adjust form size
height:=img_background.Picture.Height;
width:=img_background.picture.width;
end;
// Now show the completed form
delaytimer.Enabled := True;
FadeInTimer.Enabled := True;
Application.ProcessMessages;
ShowModal; // Closed via the Timer event or a user click
fAlreadyShown:=TRUE;
end;
except
On E: Exception do
raise Exception.CreateFmt('%s Error: %s', [Name, Exception.ClassName]);
end;
finally
FreeAndNil(img_background);
FreeAndNil(MyBitMap);
FreeAndNil(delayTimer);
FreeAndNil(FadeInTimer);
FreeAndNil(fPoweredByForm);
end;
end;
initialization
// Load graphics as lazarus resources into the component
{$I graphics.lrs}
end.

40
splashabout_component/readme.txt Normal file
View File

@@ -0,0 +1,40 @@
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 [Packages] menu open the package file splashabout.lpk
In the resulting dialog, click [Compile] then [Use] -> Install
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.
To test:
* Open the Example application (components/splashabout/exampleapp folder) 'project1.lpr'
* Run the application
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 'exampleapp' example project to experiment

292
splashabout_component/scrolltextclass.pas Normal file
View File

@@ -0,0 +1,292 @@
{
***************************************************************************
* *
* This source is free software; you can redistribute it and/or modify *
* it under the terms of the GNU General Public License as published by *
* the Free Software Foundation; either version 2 of the License, or *
* (at your option) any later version. *
* *
* This code 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 *
* General Public License for more details. *
* *
* A copy of the GNU General Public License is available on the World *
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
* obtain it by writing to the Free Software Foundation, *
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *
* *
***************************************************************************
* This unit is part of the visual component SplashAbout
* Code is adapted from the Lazarus IDE code
* by minesadorada@charcodelvalle.com
}
unit scrolltextclass;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
ExtCtrls,LCLIntf;
CONST
C_TEXTFILENAME='credits.txt';
C_VERSION='1.0.0.0';
type
TScrollTextClass = class(TGraphicControl)
private
FActive: boolean;
FActiveLine: integer; //the line over which the mouse hovers
FBuffer: TBitmap;
FEndLine: integer;
FLineHeight: integer;
FLines: TStrings;
FNumLines: integer;
FOffset: integer;
FStartLine: integer;
FStepSize: integer;
FTimer: TTimer;
FFont:TFont;
FBackColor:TColor;
FUseTextFile:Boolean;
fTextFileName:String;
fVersionString:String;
function ActiveLineIsURL: boolean;
procedure DoTimer(Sender: TObject);
procedure SetActive(const AValue: boolean);
procedure Init;
procedure DrawScrollingText(Sender: TObject);
Procedure SetLines(AValue:TStrings);
Procedure SetFont(AValue:TFont);
protected
procedure DoOnChangeBounds; override;
procedure MouseDown(Button: TMouseButton; Shift:TShiftState; X,Y:Integer); override;
procedure MouseMove(Shift: TShiftState; X,Y: Integer); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
// Can be set in design mode. Note URL links are inactive in design mode
property Active: boolean read FActive write SetActive;
// Inherited property
property Align;
// Inherited property
property Borderspacing;
// Can be set in design or runtime mode. UseTextFile property overrides.
property Lines: TStrings read FLines write SetLines;
// Sets the background color of the window
property BackColor:TColor read fBackColor write fBackColor default clWindow;
// Sets the font properties of the scrolling text
property Font:TFont read fFont Write SetFont;
// If TRUE then the file 'scrolling.txt' sould be in the application folder
property UseTextFile:Boolean read fUseTextFile write fUseTextFile default FALSE;
// Read-only property to remind you of the correct file name
property TextFileName:String read fTextFileName;
// Version number of this component
property Version:String read fVersionString;
end;
implementation
Procedure TScrollTextClass.SetFont(AValue:TFont);
begin
fFont.Assign(AValue);
end;
Procedure TScrollTextClass.SetLines(AValue:TStrings);
begin
fLines.Assign(AValue);
end;
procedure TScrollTextClass.SetActive(const AValue: boolean);
begin
FActive := AValue;
if FActive then
Init;
FTimer.Enabled:=Active;
end;
procedure TScrollTextClass.Init;
begin
FBuffer.Width := Width;
FBuffer.Height := Height;
FLineHeight := FBuffer.Canvas.TextHeight('X');
FNumLines := FBuffer.Height div FLineHeight;
if FOffset = -1 then
FOffset := FBuffer.Height;
with FBuffer.Canvas do
begin
Brush.Color := fBackColor;
Brush.Style := bsSolid;
FillRect(0, 0, Width, Height);
end;
If (fLines.Count = 0) then
begin
fLines.Add('This is the Credits scrolling window.');
fLines.Add(' ');
fLines.Add('This default text is showing because you either:');
fLines.Add(' ');
fLines.Add('1) Haven''t set any text in the CreditLines property. or');
fLines.Add('2) the file specified in the ');
fLines.Add('CreditsTextFileName property is absent or empty.');
fLines.Add(' ');
fLines.Add('Note that URL links such as');
fLines.Add('http://http://wiki.lazarus.freepascal.org/Main_Page');
fLines.Add('are clickable by the user');
fLines.Add(' ');
fLines.Add(' ');
fLines.Add('The standalone visual component TScrollTextClass is available at:');
fLines.Add('http://www.charcodelvalle.com/scrollingtext/scrollingtext_component.zip');
fLines.Add(' ');
fLines.Add('June 2014');
end;
end;
procedure TScrollTextClass.DrawScrollingText(Sender: TObject);
begin
if Active then
Canvas.Draw(0,0,FBuffer);
end;
procedure TScrollTextClass.DoTimer(Sender: TObject);
var
w: integer;
s: string;
i: integer;
begin
if not Active then
Exit;
Dec(FOffset, FStepSize);
if FOffSet < 0 then
FStartLine := -FOffset div FLineHeight
else
FStartLine := 0;
FEndLine := FStartLine + FNumLines + 1;
if FEndLine > FLines.Count - 1 then
FEndLine := FLines.Count - 1;
FBuffer.Canvas.FillRect(Rect(0, 0, FBuffer.Width, FBuffer.Height));
for i := FEndLine downto FStartLine do
begin
s := Trim(FLines[i]);
//reset buffer font
FBuffer.Canvas.Font:=fFont;
FBuffer.Canvas.Font.Style := [];
FBuffer.Canvas.Font.Color := clBlack;
//skip empty lines
if Length(s) > 0 then
begin
//check for bold format token
if s[1] = '#' then
begin
s := copy(s, 2, Length(s) - 1);
FBuffer.Canvas.Font.Style := [fsBold];
end
else
begin
//check for url
if Pos('http://', s) = 1 then
begin
if i = FActiveLine then
begin
FBuffer.Canvas.Font.Style := [fsUnderline];
FBuffer.Canvas.Font.Color := clRed;
end
else
FBuffer.Canvas.Font.Color := clBlue;
end;
end;
w := FBuffer.Canvas.TextWidth(s);
FBuffer.Canvas.TextOut((FBuffer.Width - w) div 2, FOffset + i * FLineHeight, s);
end;
end;
//start showing the list from the start
if FStartLine > FLines.Count - 1 then
FOffset := FBuffer.Height;
Invalidate;
end;
function TScrollTextClass.ActiveLineIsURL: boolean;
begin
if (FActiveLine > 0) and (FActiveLine < FLines.Count) then
Result := Pos('http://', FLines[FActiveLine]) = 1
else
Result := False;
end;
procedure TScrollTextClass.DoOnChangeBounds;
begin
inherited DoOnChangeBounds;
Init;
end;
procedure TScrollTextClass.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited MouseDown(Button, Shift, X, Y);
if ActiveLineIsURL then
OpenURL(FLines[FActiveLine]);
end;
procedure TScrollTextClass.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
inherited MouseMove(Shift, X, Y);
//calculate what line is clicked from the mouse position
FActiveLine := (Y - FOffset) div FLineHeight;
Cursor := crDefault;
if (FActiveLine >= 0) and (FActiveLine < FLines.Count) and ActiveLineIsURL then
Cursor := crHandPoint;
end;
constructor TScrollTextClass.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := ControlStyle + [csOpaque];
OnPaint := @DrawScrollingText;
FLines := TStringList.Create;
FTimer := TTimer.Create(nil);
FTimer.OnTimer:=@DoTimer;
FTimer.Interval:=30;
FBuffer := TBitmap.Create;
FFont:=TFont.Create;
FFont.Size:=10;
fBackColor:=clWindow;
FStepSize := 1;
FStartLine := 0;
FOffset := -1;
Width:=100;
Height:=100;
fTextFileName:=C_TEXTFILENAME;
fVersionString:=C_VERSION;
SendToBack;
end;
destructor TScrollTextClass.Destroy;
begin
FLines.Free;
FTimer.Free;
FBuffer.Free;
FFont.Free;
inherited Destroy;
end;
end.

73
splashabout_component/splashabout.lpk Normal file
View File

@@ -0,0 +1,73 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="splashabout"/>
<Author Value="Gordon Bamber (minesadorada@charcodelvalle.com)"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<Checks>
<IOChecks Value="True"/>
<RangeChecks Value="True"/>
</Checks>
<SmallerCode Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
</Linking>
<Other>
<Verbosity>
<ShowCond Value="True"/>
</Verbosity>
<WriteFPCLogo Value="False"/>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</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
"/>
<Version Major="1" Minor="4" Release="3"/>
<Files Count="3">
<Item1>
<Filename Value="usplashabout.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="usplashabout"/>
</Item1>
<Item2>
<Filename Value="uversion.pas"/>
<UnitName Value="uversion"/>
</Item2>
<Item3>
<Filename Value="scrolltextclass.pas"/>
<UnitName Value="scrolltextclass"/>
</Item3>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="poweredby"/>
</Item1>
<Item2>
<PackageName Value="IDEIntf"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

21
splashabout_component/splashabout.pas Normal file
View File

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

1318
splashabout_component/usplashabout.pas Normal file
View File

File diff suppressed because it is too large Load Diff

332
splashabout_component/uversion.pas Normal file
View File

@@ -0,0 +1,332 @@
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
*)
Uses
Classes, SysUtils,FPCAdds;
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;
function GetLocalizedBuildDate(): 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;
{The compiler generated date string is always of the form y/m/d.
This function gives it a string respresentation according to the
shortdateformat}
function GetLocalizedBuildDate(): string;
var
BuildDate: string;
SlashPos1, SlashPos2: integer;
Date: TDateTime;
begin
BuildDate := {$I %date%};
SlashPos1 := Pos('/',BuildDate);
SlashPos2 := SlashPos1 +
Pos('/', Copy(BuildDate, SlashPos1+1, Length(BuildDate)-SlashPos1));
Date := EncodeDate(StrToWord(Copy(BuildDate,1,SlashPos1-1)),
StrToWord(Copy(BuildDate,SlashPos1+1,SlashPos2-SlashPos1-1)),
StrToWord(Copy(BuildDate,SlashPos2+1,Length(BuildDate)-SlashPos2)));
Result := FormatDateTime('yyyy-mm-dd', Date);
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 := GetLocalizedBuildDate; //{$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.