diff --git a/components/longtimer/aboutlongtimerunit.pas b/components/longtimer/aboutlongtimerunit.pas new file mode 100644 index 000000000..206e725d2 --- /dev/null +++ b/components/longtimer/aboutlongtimerunit.pas @@ -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 Aboutunit +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 + 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, '', +{$I %DATE%} + ); + sLicenseString := AnsiReplaceText(sLicenseString, '', fAuthorname); + sLicenseString := AnsiReplaceText(sLicenseString, '', + '(' + fAuthorEmail + ')'); + sLicenseString := AnsiReplaceText(sLicenseString, '', + 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. diff --git a/components/longtimer/demo/longtimerdemo.ico b/components/longtimer/demo/longtimerdemo.ico new file mode 100644 index 000000000..0341321b5 Binary files /dev/null and b/components/longtimer/demo/longtimerdemo.ico differ diff --git a/components/longtimer/demo/longtimerdemo.lpi b/components/longtimer/demo/longtimerdemo.lpi new file mode 100644 index 000000000..347c7a88a --- /dev/null +++ b/components/longtimer/demo/longtimerdemo.lpi @@ -0,0 +1,174 @@ + + + + + + + + + + <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> diff --git a/components/longtimer/demo/longtimerdemo.lpr b/components/longtimer/demo/longtimerdemo.lpr new file mode 100644 index 000000000..83e411f62 --- /dev/null +++ b/components/longtimer/demo/longtimerdemo.lpr @@ -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. + diff --git a/components/longtimer/demo/longtimerdemo.res b/components/longtimer/demo/longtimerdemo.res new file mode 100644 index 000000000..7c6cf3e4b Binary files /dev/null and b/components/longtimer/demo/longtimerdemo.res differ diff --git a/components/longtimer/demo/umainform.lfm b/components/longtimer/demo/umainform.lfm new file mode 100644 index 000000000..5124e2f91 --- /dev/null +++ b/components/longtimer/demo/umainform.lfm @@ -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 diff --git a/components/longtimer/demo/umainform.pas b/components/longtimer/demo/umainform.pas new file mode 100644 index 000000000..669360cec --- /dev/null +++ b/components/longtimer/demo/umainform.pas @@ -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. + diff --git a/components/longtimer/lang_longtimer/aboutlongtimerunit.po b/components/longtimer/lang_longtimer/aboutlongtimerunit.po new file mode 100644 index 000000000..a0cda86c3 --- /dev/null +++ b/components/longtimer/lang_longtimer/aboutlongtimerunit.po @@ -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 "" + diff --git a/components/longtimer/license.lrs b/components/longtimer/license.lrs new file mode 100644 index 000000000..49eaf6f05 --- /dev/null +++ b/components/longtimer/license.lrs @@ -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.' +]); diff --git a/components/longtimer/longtimerpackage.lpk b/components/longtimer/longtimerpackage.lpk new file mode 100644 index 000000000..65496543f --- /dev/null +++ b/components/longtimer/longtimerpackage.lpk @@ -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 < 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> diff --git a/components/longtimer/longtimerpackage.pas b/components/longtimer/longtimerpackage.pas new file mode 100644 index 000000000..155cb8bfb --- /dev/null +++ b/components/longtimer/longtimerpackage.pas @@ -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. diff --git a/components/longtimer/ulongtimer.pas b/components/longtimer/ulongtimer.pas new file mode 100644 index 000000000..a400cf260 --- /dev/null +++ b/components/longtimer/ulongtimer.pas @@ -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.