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

Initial commit v0.0.1

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3519 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
2014-09-03 11:29:58 +00:00
parent 1235455ce1
commit b741fd8d06
12 changed files with 1623 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

624
components/longtimer/aboutlongtimerunit.pas Normal file
View File

@ -0,0 +1,624 @@
{ TAboutComponent 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.
}
// Change the name of this unit and its PAS file to be unique to your component
// Unit About<yourcomponentname>unit
unit AboutLongTimerunit;
{$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; // Forward declaration
// Do Search/Replace to change all instances of TAboutComonent
// to TAbout<yourcomponentname>
TAboutLongTimer = class(TCustomIdleTimer)
// This class can descend from any component class (TGraphicControl etc
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 TAboutLongTimer
// About this component...
property About: tAboutBox read fAboutBox write fAboutBox;
end;
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;
// 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.0';
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;
{ TAboutLongTimer }
procedure Register;
begin
RegisterPropertyEditor(TypeInfo(TAboutbox),
TAboutLongTimer, '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 TAboutLongTimer.SetMyComponentName(Const Avalue:String);
begin
fAboutBox.ComponentName:=AValue;
fAboutBox.Title:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxWidth(Const AValue:Integer);
begin
fAboutBox.Width:=Avalue;
end;
procedure TAboutLongTimer.SetAboutBoxHeight(Const AValue:Integer);
begin
fAboutBox.Height:=Avalue;
end;
procedure TAboutLongTimer.SetAboutBoxDescription(Const AValue:String);
begin
fAboutBox.Description.Clear;
fAboutBox.Description.Add(AValue);
end;
procedure TAboutLongTimer.SetAboutBoxFontName(Const AValue:String);
begin
fAboutBox.Font.Name:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxFontSize(Const AValue:Integer);
begin
if (AValue > 6) then fAboutBox.Font.Size:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxTitle(Const AValue:String);
begin
fAboutBox.Title:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxBitmap(Const AValue:TBitmap);
begin
If Assigned(Avalue) then fAboutBox.Assign(AValue);
end;
procedure TAboutLongTimer.SetAboutBoxBackgroundColor(Const AValue:TColor);
begin
fAboutBox.BackGroundColor:=AValue;;
end;
procedure TAboutLongTimer.SetAboutBoxVersion(Const AValue:String);
begin
fAboutBox.Version:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxAuthorname(Const AValue:String);
begin
fAboutBox.Authorname:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxOrganisation(Const AValue:String);
begin
fAboutBox.Organisation:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxAuthorEmail(Const AValue:String);
begin
fAboutBox.AuthorEmail:=AValue;
end;
procedure TAboutLongTimer.SetAboutBoxBackgroundResourceName(Const AValue:String);
begin
fAboutBox.BackgroundResourceName:=AValue;
end;
procedure TAboutLongTimer.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 TAboutLongTimer.SetAboutBoxStretchBackgroundImage(Const AValue:Boolean);
begin
fAboutBox.StretchBackground:=AValue;
end;
// End Sets
constructor TAboutLongTimer.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 TAboutLongTimer values override TAbouBox.Create defaults
ComponentName := 'TAboutLongTimer';
Description.Add('This is to demonstrate'); //TStrings
Description.Add('the use of TAboutLongTimer'); //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 TAboutLongTimer.Destroy;
begin
FreeAndNil(fAboutBox);
inherited Destroy;
end;
initialization
{$I license.lrs}
end.

BIN
components/longtimer/demo/longtimerdemo.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

174
components/longtimer/demo/longtimerdemo.lpi Normal file
View File

@ -0,0 +1,174 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="LongTimer Demo"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</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)"/>
<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>
</CodeGeneration>
<Linking>
<Debugging>
<DebugInfoType Value="dsDwarf2Set"/>
<UseHeaptrc Value="True"/>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item2>
<Item3 Name="Release">
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="longtimerdemo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="."/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
<Optimizations>
<OptimizationLevel Value="3"/>
</Optimizations>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="False"/>
</Debugging>
<LinkSmart Value="True"/>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</Item3>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="longtimerpackage"/>
<MinVersion Release="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="longtimerdemo.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="longtimerdemo"/>
</Unit0>
<Unit1>
<Filename Value="umainform.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="mainform"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="umainform"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<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>
<MsgFileName Value=""/>
</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
components/longtimer/demo/longtimerdemo.lpr Normal file
View File

@ -0,0 +1,21 @@
program longtimerdemo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, umainform;
{$R *.res}
begin
Application.Title:='LongTimer Demo';
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(Tmainform, mainform);
Application.Run;
end.

BIN
components/longtimer/demo/longtimerdemo.res Normal file
View File

Binary file not shown.

159
components/longtimer/demo/umainform.lfm Normal file
View File

@ -0,0 +1,159 @@
object mainform: Tmainform
Left = 1162
Height = 264
Top = 272
Width = 437
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'Application Title'
ClientHeight = 264
ClientWidth = 437
DefaultMonitor = dmPrimary
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '1.2.4.0'
object cmd_Close: TBitBtn
Left = 104
Height = 30
Top = 224
Width = 75
DefaultCaption = True
Kind = bkClose
ModalResult = 11
TabOrder = 0
end
object memo_ReportTimerEvent: TMemo
Left = 192
Height = 240
Top = 8
Width = 232
Lines.Strings = (
'Memo1'
)
TabOrder = 1
end
object cmd_StopTimer: TButton
Left = 16
Height = 25
Top = 197
Width = 75
Caption = 'Stop Timer'
OnClick = cmd_StopTimerClick
TabOrder = 2
end
object cmd_StartTimer: TButton
Left = 104
Height = 25
Top = 197
Width = 75
Caption = 'Start Timer'
OnClick = cmd_StartTimerClick
TabOrder = 3
end
object crp_SetTimer: TGroupBox
Left = 8
Height = 176
Top = 8
Width = 184
Caption = 'Set up LongTimer'
ClientHeight = 158
ClientWidth = 180
TabOrder = 4
object Label1: TLabel
Left = 16
Height = 15
Top = 16
Width = 28
Caption = 'Every'
ParentColor = False
end
object cmb_IntervalType: TComboBox
Left = 72
Height = 23
Top = 16
Width = 100
ItemHeight = 15
ItemIndex = 0
Items.Strings = (
'Day'
'Week'
'Month'
)
OnChange = cmb_IntervalTypeChange
Style = csDropDownList
TabOrder = 0
Text = 'Day'
end
object Label3: TLabel
Left = 0
Height = 15
Top = 48
Width = 61
Caption = 'Day or Date'
ParentColor = False
end
object cmb_weekordate: TComboBox
Left = 72
Height = 23
Top = 44
Width = 100
Enabled = False
ItemHeight = 15
OnChange = cmb_weekordateChange
Style = csDropDownList
TabOrder = 1
end
object Label2: TLabel
Left = 0
Height = 15
Top = 88
Width = 61
Caption = 'Time (24hr)'
ParentColor = False
end
object cmb_Daily24Hour: TComboBox
Left = 72
Height = 23
Top = 88
Width = 100
ItemHeight = 15
ItemIndex = 0
Items.Strings = (
'Midnight'
)
OnChange = cmb_Daily24HourChange
Style = csDropDownList
TabOrder = 2
Text = 'Midnight'
end
object cmb_SampleInterval: TComboBox
Left = 48
Height = 23
Top = 128
Width = 124
ItemHeight = 15
OnChange = cmb_SampleIntervalChange
Style = csDropDownList
TabOrder = 3
end
object Label4: TLabel
Left = 0
Height = 15
Top = 128
Width = 39
Caption = 'Sample'
ParentColor = False
end
end
object LongTimer1: TLongTimer
Enabled = False
OnTimer = LongTimer1Timer
OnStartTimer = LongTimer1StartTimer
OnStopTimer = LongTimer1StopTimer
IntervalType = lt3Monthly
Daily24Hour = 10
WeeklyDay = lt3Wednesday
left = 8
top = 8
end
end

174
components/longtimer/demo/umainform.pas Normal file
View File

@ -0,0 +1,174 @@
unit umainform;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms,
Buttons, StdCtrls, uLongTimer;
{ Tmainform }
type
Tmainform = class(TForm)
cmb_Daily24Hour: TComboBox;
cmb_IntervalType: TComboBox;
cmb_weekordate: TComboBox;
cmd_Close: TBitBtn;
cmd_StopTimer: TButton;
cmd_StartTimer: TButton;
cmb_SampleInterval: TComboBox;
crp_SetTimer: TGroupBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
LongTimer1: TLongTimer;
memo_ReportTimerEvent: TMemo;
procedure cmb_SampleIntervalChange(Sender: TObject);
procedure cmd_StopTimerClick(Sender: TObject);
procedure cmd_StartTimerClick(Sender: TObject);
procedure cmb_Daily24HourChange(Sender: TObject);
procedure cmb_IntervalTypeChange(Sender: TObject);
procedure cmb_weekordateChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure LongTimer1StartTimer(Sender: TObject);
procedure LongTimer1StopTimer(Sender: TObject);
procedure LongTimer1Timer(Sender: TObject);
private
{ private declarations }
procedure PopulateWeekOrDate(Const i:Integer);
public
{ public declarations }
end;
var
mainform: Tmainform;
implementation
{$R *.lfm}
{ Tmainform }
procedure Tmainform.LongTimer1Timer(Sender: TObject);
begin
// memo_ReportTimerEvent.Lines.Add('LastFired at ' + FormatDateTime('hh:nn:ss', LongTimer1.LastFired));
memo_ReportTimerEvent.Lines.Add('Fired at ' + FormatDateTime('hh:nn:ss', Now));
end;
procedure Tmainform.FormCreate(Sender: TObject);
Var i:Integer;
begin
Caption:=Application.Title;
memo_ReportTimerEvent.Clear;
cmb_Daily24Hour.Clear;
cmb_Daily24Hour.Items.Add('Midnight');
For i:=1 to 23 do
cmb_Daily24Hour.Items.Add(Format('%2.d:00',[i]));
LongTimer1.IntervalType:=lt1Daily;
LongTimer1.Daily24Hour:=0;
LongTimer1.Enabled:=FALSE;
cmb_Daily24Hour.ItemIndex:=0;
cmb_SampleInterval.Clear;
cmb_SampleInterval.Items.Add('Every minute');
cmb_SampleInterval.Items.Add('Every 5 minutes');
cmb_SampleInterval.Items.Add('Every 10 minutes');
cmb_SampleInterval.Items.Add('Every 30 minutes');
cmb_SampleInterval.Items.Add('Every 45 minutes');
memo_ReportTimerEvent.Lines.Add('Timer initially disabled');
cmb_SampleInterval.ItemIndex:=2;
end;
procedure Tmainform.LongTimer1StartTimer(Sender: TObject);
begin
// memo_ReportTimerEvent.Lines.Add('Timer running');
end;
procedure Tmainform.LongTimer1StopTimer(Sender: TObject);
begin
// memo_ReportTimerEvent.Lines.Add('Timer stopped');
end;
procedure Tmainform.cmd_StopTimerClick(Sender: TObject);
begin
LongTimer1.Enabled:=FALSE;
memo_ReportTimerEvent.Lines.Add('Timer disabled');
end;
procedure Tmainform.cmb_SampleIntervalChange(Sender: TObject);
begin
LongTimer1.SampleInterval:=TSampleInterval(cmb_SampleInterval.ItemIndex);
end;
procedure Tmainform.cmd_StartTimerClick(Sender: TObject);
begin
LongTimer1.Enabled:=TRUE;
memo_ReportTimerEvent.Lines.Add('Timer enabled');
end;
procedure Tmainform.cmb_Daily24HourChange(Sender: TObject);
begin
LongTimer1.Daily24Hour:=cmb_Daily24Hour.ItemIndex;
end;
procedure Tmainform.PopulateWeekOrDate(Const i:Integer);
// 0=Weekly, 1=Monthly
Var iMonthDay:Integer;
begin
cmb_weekordate.Clear;
Case i of
0:begin
cmb_weekordate.Items.Add('Monday');
cmb_weekordate.Items.Add('Tuesday');
cmb_weekordate.Items.Add('Wednesday');
cmb_weekordate.Items.Add('Thursday');
cmb_weekordate.Items.Add('Friday');
cmb_weekordate.Items.Add('Saturday');
cmb_weekordate.Items.Add('Sunday');
end;
1:begin
For iMonthDay := 1 to 31 do
cmb_weekordate.Items.Add(Format('%2.d',[iMonthDay]));
end;
end;
cmb_weekordate.ItemIndex:=0;
end;
procedure Tmainform.cmb_IntervalTypeChange(Sender: TObject);
begin
cmd_StopTimer.Click;
Case cmb_IntervalType.ItemIndex of
0:
begin
LongTimer1.IntervalType:=lt1Daily;
cmb_weekordate.Enabled:=FALSE;
end;
1:
begin
LongTimer1.IntervalType:=lt2Weekly;
PopulateWeekOrDate(0);
cmb_weekordate.Enabled:=TRUE;
end;
2:
begin
LongTimer1.IntervalType:=lt3Monthly;
PopulateWeekOrDate(1);
cmb_weekordate.Enabled:=TRUE;
end;
end;
end;
procedure Tmainform.cmb_weekordateChange(Sender: TObject);
begin
Case LongTimer1.IntervalType of
lt2Weekly:LongTimer1.WeeklyDay:=TDay(cmb_weekordate.ItemIndex);
lt3Monthly:LongTimer1.MonthlyDate:=(cmb_weekordate.ItemIndex+1);
end;
end;
end.

35
components/longtimer/lang_longtimer/aboutlongtimerunit.po Normal file
View File

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

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

54
components/longtimer/longtimerpackage.lpk Normal file
View File

@ -0,0 +1,54 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="longtimerpackage"/>
<Author Value="minesadorada@charcodelvalle.com"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
<CompilerMessages>
<MsgFileName Value=""/>
</CompilerMessages>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Description Value="TLongTimer is a descendant of TIdleTimer that samples every 30minutes when idle.
It is intended for TTrayIcon applications. DailyHour is a 24-hour clock (16 = 4pm) and MonthlyDate is best &lt; 29 "/>
<License Value="LGPLv2"/>
<Version Release="1"/>
<Files Count="2">
<Item1>
<Filename Value="ulongtimer.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="uLongTimer"/>
</Item1>
<Item2>
<Filename Value="aboutlongtimerunit.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="AboutLongTimerunit"/>
</Item2>
</Files>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="lang_longtimer"/>
<EnableI18NForLFM Value="True"/>
</i18n>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

22
components/longtimer/longtimerpackage.pas Normal file
View File

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

288
components/longtimer/ulongtimer.pas Normal file
View File

@ -0,0 +1,288 @@
unit uLongTimer;
{ TlongTimer
Based on TIdleTimer component
1. Set the Interval type
2. For all Interval Types, you can set the Hour
3. The OnTimer event will only be fired at the specified intervals
4. The underlying interval is 30 minutes (when idle)
Copyright (C)2014 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.
}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, ExtCtrls,DateUtils,Dialogs,AboutLongTimerunit;
type
TIntervalType = (lt1Daily,lt2Weekly,lt3Monthly);
TSampleInterval = (lt1Everyminute,lt2Every5minutes,lt3Every10Minutes,lt4Every30Minutes,lt5Every45Minutes);
TDay = (lt1Monday,lt2Tuesday,lt3Wednesday,lt4Thursday,lt5Friday,lt6Saturday,lt7Sunday);
TLongTimer = class(TAboutLongTimer)
private
{ Private declarations }
fCurrentDateTime,fLastFiredDateTime:TDateTime;
fIntervalType:TIntervalType;
fHour,fDay,fDate:Word;
fTday:TDay;
fHourDone,fDayDone,fDateDone:Boolean;
fSampleInterval:TSampleInterval;
protected
{ Protected declarations }
procedure DoOnIdle(Sender: TObject; var Done: Boolean); override;
procedure DoOnIdleEnd(Sender: TObject); override;
procedure DoOnTimer;override;
Procedure SetDay(aDay:TDay);
Procedure SetDailyHour(aHour:Word);
Procedure SetMonthlyDate(ADate:Word);
procedure SetSampleInterval(ASampleInterval:TSampleInterval);
public
{ Public declarations }
constructor Create(TheOwner: TComponent); override;
published
{ Published declarations }
// Default=false
property AutoEnabled;
// Same as TIdleTimer
property AutoStartEvent;
// Same as TIdleTimer
property AutoEndEvent;
// Same as TIdleTimer
property Enabled;
// This is fired only at the Long Intervals you set
property OnTimer;
// Same as TIdleTimer
property OnStartTimer;
// Same as TIdleTimer
property OnStopTimer;
// If Weekly or Monthly you can also set the Daily24Hour property
property IntervalType:TIntervalType read fIntervalType write fIntervalType default lt1Daily;
// Smaller = more accurate, larger = less CPU time
property SampleInterval:TSampleInterval read fSampleInterval write SetSampleInterval default lt3Every10Minutes;
// 0=Midnight, 4=4am, 16=4pm etc.
Property Daily24Hour:Word read fHour write SetDailyHour;
// You can also set the Hour as well as the Weekday
Property WeeklyDay:TDay read fTDay write SetDay;
// You can also set the hour as well as the date
property MonthlyDate:Word read fDate write SetMonthlyDate default 1;
// Until the first Timer event, this will be the component's creation time
Property LastFired:TDateTime read fLastFiredDateTime;
end;
procedure Register;
implementation
CONST
C_OneMinute = 60000;
procedure Register;
begin
RegisterComponents('System',[TLongTimer]);
end;
constructor TLongTimer.Create(TheOwner: TComponent);
Var sz:String;
begin
inherited;
// Set About dialog properties
AboutBoxComponentName:='TLongTimer';
AboutBoxTitle:='TLongTimer Component';
// AboutBoxWidth (integer)
AboutBoxHeight:=380;
sz:='LongTimer is a descendent of TIdleTimer' + LineEnding;
sz+='and shares its properties and methods.' + LineEnding + LineEnding;
sz+='Additional properties affect when the' + LineEnding;
sz+='OnTimer event is fired.' + LineEnding + LineEnding;
sz+='With LongTimer, the OnTimer event' + LineEnding;
sz+='will be fired only ONCE - every time' + LineEnding;
sz+='the interval that you set is reached.';
AboutBoxDescription:=sz;
// AboutBoxBackgroundColor (TColor, like clWhite)
// AboutBoxFontName (string)
// AboutBoxFontSize (integer)
AboutBoxVersion:='0.0.1';
AboutBoxAuthorname:='Gordon Bamber';
// AboutBoxOrganisation (string)
AboutBoxAuthorEmail:='minesadorada@charcodelvalle.com';
AboutBoxLicenseType:='LGPL';// (string e.g. 'GPL', ModifiedGPL' etc
fHourDone:=false;
fDayDone:=False;
fDateDone:=False;
fCurrentDateTime:=Now;
fLastFiredDateTime:=Now;
fDate:=1;
fSampleInterval:=lt3Every10Minutes;
Interval:=10 * C_OneMinute;
fIntervalType:=lt1Daily;
end;
procedure TLongTimer.DoOnIdle(Sender: TObject; var Done: Boolean);
begin
// Do nothing special here
inherited;
end;
procedure TLongTimer.DoOnIdleEnd(Sender: TObject);
begin
// Do nothing special here
inherited;
end;
procedure TLongTimer.DoOnTimer;
// Only allow this event to fire ONCE if datetime matches the interval set
Var
cDay,cD,cM,cY,cH,cMi,cS,cms:Word;
lDay,lD,lM,lY,lH,lMi,lS,lms:Word;
fTempDate:Word;
begin
// Split Current date into parts
fCurrentDateTime:=Now;
DecodeDate(fCurrentDateTime,cY,cM,cD);
DecodeTime(fCurrentDateTime,cH,cMi,cS,cmS);
cDay:=DayOfTheMonth(fCurrentDateTime);
DecodeDate(fLastFiredDateTime,lY,lM,lD);
DecodeTime(fLastFiredDateTime,lH,lMi,lS,lmS);
lDay:=DayOfTheMonth(fLastFiredDateTime);
// New hour?
If (fIntervalType = lt1Daily) then
If (cH <> lH) then fHourDone:=FALSE;
// New Day?
If (fIntervalType = lt2Weekly) then
If (cDay <> lDay) then
begin
fDayDone:=FALSE;
fHourDone:=FALSE;
end;
// New Date?
If (fIntervalType = lt3Monthly) then
If (cD <> lD) then
begin
fDateDone:=FALSE;
fHourDone:=FALSE;
end;
// Only proceed further at specified interval in specified hour - else exit
If (fIntervalType = lt1Daily) and ((fHourDone = TRUE) OR (cH <> fHour)) then Exit;
If (fIntervalType = lt2Weekly) and ((fDayDone = TRUE) OR (cH <> fHour)) then Exit;
If (fIntervalType = lt3Monthly) and ((fDateDone = TRUE) OR (cH <> fHour)) then Exit;
// Fire the OnTimer event for the user
inherited; // Do whatever the user wants done
fLastFiredDateTime:=Now;// Record the DateTime the OnTimer was fired
// Now make sure it doesn't fire more than once when resampled
// Deal with Months where fDate has been set to an invalid date
// (i.e. 31st February)
// Simply temporarily decrement the fDate until it is valid
fTempDate:=fDate;
If (fIntervalType = lt3Monthly) then
While NOT IsValidDate(cY,cM,fTempDate) do Dec(fTempDate);
// If ltDaily, then fDayDone and fDateDone are always FALSE
If (fIntervalType = lt1Daily) and (cH = fHour) then
begin
fHourDone := TRUE;
end;
// If ltWeekly, then fHourDone and fDateDone are always FALSE
// Set only if on Correct Weekday and at specified hour
If (fIntervalType = lt2Weekly)
and ((cDay = fDay)
and (ch = fHour))
then
begin
fDayDone := TRUE;
fHourDone := TRUE;
end;
// If ltMonthly, then fDayDone and fHourDone are always FALSE
// Set only if Correct day of month and at specified hour
If (fIntervalType = lt3Monthly) and
((cD = fTempDate)
and (ch = fHour))
then
begin
fDateDone := TRUE;
fHourDone := TRUE;
end;
end;
procedure TLongTimer.SetSampleInterval(ASampleInterval:TSampleInterval);
Var TimerEnabled:Boolean;
Begin
If ASampleInterval = fSampleInterval then exit;
// Temporarily disable running timer?
TimerEnabled:=Enabled;
Enabled:=False;
Case ASampleInterval of
lt1Everyminute:Interval:=C_OneMinute;
lt2Every5minutes:Interval:=5 * C_OneMinute;
lt3Every10Minutes:Interval:=10 * C_OneMinute;
lt4Every30Minutes:Interval:=30 * C_OneMinute;
lt5Every45Minutes:Interval:=45 * C_OneMinute;
end;
Enabled:=TimerEnabled;
end;
Procedure TLongTimer.SetDay(aDay:TDay);
Var TimerEnabled:Boolean;
begin
If ADay = fTDay then Exit;
// Temporarily disable running timer?
TimerEnabled:=Enabled;
Enabled:=False;
fTDay:=aDay;
fDay:=Ord(aDay)+1;
Enabled:=TimerEnabled;
{
// ISO day numbers.
DayMonday = 1;
DayTuesday = 2;
DayWednesday = 3;
DayThursday = 4;
DayFriday = 5;
DaySaturday = 6;
DaySunday = 7;
}
end;
Procedure TLongTimer.SetDailyHour(aHour:Word);
Var TimerEnabled:Boolean;
begin
If fHour=aHour then Exit;
// Temporarily disable running timer?
TimerEnabled:=Enabled;
Enabled:=False;
If (aHour >= 0) AND (aHour <=24) then fHour:=aHour;
Enabled:=TimerEnabled;
end;
Procedure TLongTimer.SetMonthlyDate(ADate:Word);
Var TimerEnabled:Boolean;
begin
If ADate=fDate then Exit;
// Temporarily disable running timer?
TimerEnabled:=Enabled;
Enabled:=False;
If (fDate > 0) and (fDate < 32) then fDate:=ADate;
// Invalid dates like 31st Feb are dealt with in DoOnTimer
// e.g. 31 stands for the last day in any month (inc Feb in a Leap Year)
Enabled:=TimerEnabled;
end;
end.