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

systools: Add code pattern and text data units (plus demos)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6147 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-01-17 18:44:39 +00:00
parent 36b42951dd
commit 133a3b98d7
35 changed files with 6060 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files

83
components/systools/examples/data_merge/datamerg.lpi Normal file
View File

@@ -0,0 +1,83 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="datamerg"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="datamerg.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="DataMerg"/>
</Unit0>
<Unit1>
<Filename Value="datamrg0.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="datamerg"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

46
components/systools/examples/data_merge/datamerg.lpr Normal file
View File

@@ -0,0 +1,46 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program DataMerg;
uses
Interfaces,
Forms, lclversion,
datamrg0 in 'datamrg0.pas' {Form1};
{$R *.res}
begin
{$IFDEF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

331
components/systools/examples/data_merge/datamrg0.lfm Normal file
View File

@@ -0,0 +1,331 @@
object Form1: TForm1
Left = 241
Height = 601
Top = 131
Width = 854
Caption = 'Data Merge Example'
ClientHeight = 601
ClientWidth = 854
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Splitter1: TSplitter
Cursor = crVSplit
Left = 0
Height = 3
Top = 408
Width = 854
Align = alBottom
ResizeAnchor = akBottom
end
object Splitter2: TSplitter
Left = 185
Height = 408
Top = 0
Width = 5
end
object Panel1: TPanel
AnchorSideTop.Side = asrCenter
Left = 0
Height = 38
Top = 563
Width = 854
Align = alBottom
ClientHeight = 38
ClientWidth = 854
TabOrder = 0
object Button1: TButton
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 5
Height = 25
Top = 7
Width = 108
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Open Template'
OnClick = Button1Click
TabOrder = 0
end
object Button2: TButton
AnchorSideLeft.Control = Button5
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 224
Height = 25
Top = 7
Width = 98
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Load Data Set'
OnClick = Button2Click
TabOrder = 2
end
object Button3: TButton
AnchorSideLeft.Control = Button6
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 431
Height = 25
Top = 7
Width = 60
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Merge'
OnClick = Button3Click
TabOrder = 4
end
object Panel5: TPanel
Left = 696
Height = 36
Top = 1
Width = 157
Align = alRight
ClientHeight = 36
ClientWidth = 157
TabOrder = 6
object SpeedButton1: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 13
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F33333333337F3E0F33333333370E337F3333F3FF337F3E0F333030033
70E337F3337F77F337F3E0F33003003370E337F3377F77F337F3E0F300030033
70E337F3777F77F337F3E0F33003003370E337F3377F77F337F3E0F333030033
70E337F33373773337F3E0F33333333370E337F33333333337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
object SpeedButton2: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 49
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
8000008000000080800080000000800080008080000080808000C0C0C0000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F33333F33337F3E0F33333033370E337F3333FF73337F3E0F333300333
70E337F333FF773337F3E0F33300033370E337F33FF7773337F3E0F330000333
70E337F33377773337F3E0F33300033370E337F33337773337F3E0F333300333
70E337F33333773337F3E0F33333033370E337F33333373337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
object SpeedButton3: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 85
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F3333F333337F3E0F33303333370E337F3337FF33337F3E0F333003333
70E337F33377FF3337F3E0F33300033370E337F333777FF337F3E0F333000033
70E337F33377773337F3E0F33300033370E337F33377733337F3E0F333003333
70E337F33377333337F3E0F33303333370E337F33373333337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
object SpeedButton4: TSpeedButton
AnchorSideTop.Control = Panel5
AnchorSideTop.Side = asrCenter
Left = 121
Height = 22
Top = 7
Width = 23
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
0400000000000001000000000000000000001000000010000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
33333333333333333333EEEEEEEEEEEEEEE333FFFFFFFFFFFFF3E00000000000
00E337777777777777F3E0F77777777770E337F33333333337F3E0F333333333
70E337F33333333337F3E0F33333333370E337F333FF3F3337F3E0F330030333
70E337F3377F7FF337F3E0F33003003370E337F3377F77FF37F3E0F330030003
70E337F3377F777337F3E0F33003003370E337F3377F773337F3E0F330030333
70E337F33773733337F3E0F33333333370E337F33333333337F3E0F333333333
70E337F33333333337F3E0FFFFFFFFFFF0E337FFFFFFFFFFF7F3E00000000000
00E33777777777777733EEEEEEEEEEEEEEE33333333333333333
}
NumGlyphs = 2
OnClick = NavClick
end
end
object Button4: TButton
AnchorSideLeft.Control = Button3
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 495
Height = 25
Top = 7
Width = 87
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Save Merge'
OnClick = Button4Click
TabOrder = 5
end
object Button5: TButton
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 117
Height = 25
Top = 7
Width = 103
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Save Template'
OnClick = Button5Click
TabOrder = 1
end
object Button6: TButton
AnchorSideLeft.Control = Button2
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 326
Height = 25
Top = 7
Width = 101
AutoSize = True
BorderSpacing.Left = 4
Caption = 'Close Data Set'
OnClick = Button6Click
TabOrder = 3
end
end
object Panel2: TPanel
Left = 0
Height = 152
Top = 411
Width = 854
Align = alBottom
ClientHeight = 152
ClientWidth = 854
TabOrder = 3
object Memo1: TMemo
Left = 1
Height = 150
Top = 1
Width = 852
Align = alClient
OnDblClick = ClearMemo
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
object Panel3: TPanel
Left = 0
Height = 408
Top = 0
Width = 185
Align = alLeft
ClientHeight = 408
ClientWidth = 185
TabOrder = 1
object Memo2: TMemo
Left = 1
Height = 406
Top = 1
Width = 183
Align = alClient
OnDblClick = ClearMemo
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
object Panel4: TPanel
Left = 190
Height = 408
Top = 0
Width = 664
Align = alClient
ClientHeight = 408
ClientWidth = 664
TabOrder = 2
object Memo3: TMemo
Left = 1
Height = 406
Top = 1
Width = 662
Align = alClient
OnDblClick = ClearMemo
ScrollBars = ssBoth
TabOrder = 0
WordWrap = False
end
end
object OpenDialog1: TOpenDialog
DefaultExt = '.txt'
FileName = '*.txt'
Filter = 'Text Files (*.txt)|*.txt|dlg'
left = 504
top = 64
end
object OpenDialog2: TOpenDialog
Title = 'Open Schema File'
DefaultExt = '.sch'
FileName = '*.sch'
Filter = 'Schema Files (*.sch)|*.sch|All Files (*.*)|*.*'
InitialDir = 'c:\cache\Data'
left = 504
top = 120
end
object OpenDialog3: TOpenDialog
Title = 'Open CSV File'
DefaultExt = '.csv'
FileName = '*.csv'
Filter = 'CSV Files (*.csv)|*.csv|All Files (*.*)|*.*'
InitialDir = 'c:\cache\data'
left = 504
top = 176
end
object SaveDialog1: TSaveDialog
left = 504
top = 232
end
object SaveDialog2: TSaveDialog
left = 504
top = 288
end
end

260
components/systools/examples/data_merge/datamrg0.pas Normal file
View File

@@ -0,0 +1,260 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit datamrg0;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, Buttons,
StTxtDat, StMerge;
type
TForm1 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Splitter1: TSplitter;
Panel3: TPanel;
Splitter2: TSplitter;
Panel4: TPanel;
Memo1: TMemo;
Memo2: TMemo;
Memo3: TMemo;
Button1: TButton;
OpenDialog1: TOpenDialog;
OpenDialog2: TOpenDialog;
OpenDialog3: TOpenDialog;
Button2: TButton;
Button3: TButton;
Panel5: TPanel;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
SpeedButton3: TSpeedButton;
SpeedButton4: TSpeedButton;
Button4: TButton;
SaveDialog1: TSaveDialog;
Button5: TButton;
SaveDialog2: TSaveDialog;
Button6: TButton;
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure NavClick(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button5Click(Sender: TObject);
procedure ClearMemo(Sender: TObject);
procedure Button6Click(Sender: TObject);
private
procedure UpdateButtons;
procedure UpdateTagDisplay;
function NextFile: string;
procedure DoUnknownTag(Sender: TObject; Tag: AnsiString;
var Value: AnsiString; var Discard: Boolean);
procedure DisableButtons;
{ Private declarations }
public
TemplateName : string;
MergeNo : Integer;
Schema : TStTextDataSchema;
DataSet : TStTextDataRecordSet;
Merger : TStTextMerge;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.Button2Click(Sender: TObject);
begin
if OpenDialog2.Execute and OpenDialog3.Execute then begin
Schema.Free;
Schema := TStTextDataSchema.Create;
Schema.LoadFromFile(OpenDialog2.FileName);
DataSet.Free;
DataSet := TStTextDataRecordSet.Create;
DataSet.Schema := Schema;
DataSet.LoadFromFile(OpenDialog3.FileName);
DataSet.First;
UpdateButtons;
UpdateTagDisplay;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Schema.Free;
DataSet.Free;
Merger.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
TemplateName := OpenDialog1.FileName;
MergeNo := 1;
Merger.LoadTemplateFromFile(TemplateName);
Memo3.Lines.Assign(Merger.Template);
end;
end;
procedure TForm1.UpdateTagDisplay;
begin
Memo2.Lines.Assign(DataSet.CurrentRecord.FieldList);
end;
procedure TForm1.DisableButtons;
begin
SpeedButton1.Enabled := False;
SpeedButton2.Enabled := False;
SpeedButton3.Enabled := False;
SpeedButton4.Enabled := False;
end;
procedure TForm1.UpdateButtons;
begin
if DataSet.Active then begin
SpeedButton1.Enabled := True;
SpeedButton2.Enabled := True;
SpeedButton3.Enabled := True;
SpeedButton4.Enabled := True;
if DataSet.BOF then begin
SpeedButton1.Enabled := False;
SpeedButton2.Enabled := False;
end;
if DataSet.EOF then begin
SpeedButton3.Enabled := False;
SpeedButton4.Enabled := False;
end;
end else
DisableButtons;
end;
procedure TForm1.NavClick(Sender: TObject);
begin
if Sender = SpeedButton1 then DataSet.First;
if Sender = SpeedButton2 then DataSet.Prior;
if Sender = SpeedButton3 then DataSet.Next;
if Sender = SpeedButton4 then DataSet.Last;
UpdateButtons;
UpdateTagDisplay;
end;
function TForm1.NextFile : string;
begin
Result := ChangeFileExt(ExtractFileName(TemplateName),
Format('.M%.2d', [MergeNo]));
Inc(MergeNo);
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
SaveDialog1.FileName := NextFile;
if SaveDialog1.Execute then begin
Memo3.Lines.SaveToFile(SaveDialog1.FileName);
end;
end;
procedure TForm1.DoUnknownTag(Sender : TObject; Tag : AnsiString;
var Value : AnsiString; var Discard : Boolean);
begin
if Tag = 'TIME' then
Value := FormatDateTime('hh:mm:ss', Now)
else
Value := InputBox('Unknown Tag', 'Value for ' + Tag, '');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Merger := TStTextMerge.Create;
Merger.DefaultTags.Add('FIRST_NAME=Sir or Madam');
Merger.DefaultTags.Add('CITY=ANYTOWN');
Merger.DefaultTags.Add('COLOR=BLUE');
Merger.OnGotUnknownTag := DoUnknownTag;
DisableButtons;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Merger.MergeTags.Assign(Memo2.Lines);
Merger.Merge;
Memo1.Lines.Assign(Merger.MergedText);
end;
procedure TForm1.Button5Click(Sender: TObject);
begin
SaveDialog2.FileName := TemplateName;
if SaveDialog2.Execute then begin
TemplateName := SaveDialog2.FileName;
Memo3.Lines.SaveToFile(TemplateName);
Merger.Template.Assign(Memo3.Lines);
end;
end;
procedure TForm1.ClearMemo(Sender: TObject);
begin
(Sender as TMemo).Lines.Clear;
end;
procedure TForm1.Button6Click(Sender: TObject);
begin
if Assigned(DataSet) and DataSet.Active then begin
DataSet.Active := False;
DataSet.Free;
DataSet := nil;
Memo2.Lines.Clear;
DisableButtons;
end;
end;
end.

3
components/systools/examples/grid_fill/data.csv Normal file
View File

@@ -0,0 +1,3 @@
"John Smith","A+",08/01/1995,135.32
"Jane Doe","B",08/12/1995,120.25
"John Q. Public","CCC",08/03/1995,145.11
1 John Smith A+ 08/01/1995 135.32
2 Jane Doe B 08/12/1995 120.25
3 John Q. Public CCC 08/03/1995 145.11

9
components/systools/examples/grid_fill/data.sch Normal file
View File

@@ -0,0 +1,9 @@
[DATES]
Field3=Data,DATA,10,00,22
Separator=,
CharSet=ascii
Field2=Rating,CHAR,2,00,20
Filetype=VARYING
Field4=Weight,Float,7,2,32
Field1=Name,CHAR,20,00,00
Delimiter="

83
components/systools/examples/grid_fill/gridfil0.lfm Normal file
View File

@@ -0,0 +1,83 @@
object Form1: TForm1
Left = 307
Height = 373
Top = 165
Width = 536
Caption = 'Grid Filler Example'
ClientHeight = 373
ClientWidth = 536
Color = clBtnFace
Font.Color = clWindowText
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 41
Top = 332
Width = 536
Align = alBottom
ClientHeight = 41
ClientWidth = 536
TabOrder = 0
object Button1: TButton
AnchorSideLeft.Control = Panel1
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 9
Height = 25
Top = 8
Width = 97
AutoSize = True
BorderSpacing.Left = 8
Caption = 'Load Schema'
OnClick = Button1Click
TabOrder = 0
end
object Button2: TButton
AnchorSideLeft.Control = Button1
AnchorSideLeft.Side = asrBottom
AnchorSideTop.Control = Panel1
AnchorSideTop.Side = asrCenter
Left = 114
Height = 25
Top = 8
Width = 103
AutoSize = True
BorderSpacing.Left = 8
Caption = 'Open Data File'
OnClick = Button2Click
TabOrder = 1
end
end
object StringGrid1: TStringGrid
Left = 0
Height = 332
Top = 0
Width = 536
Align = alClient
DefaultColWidth = 100
FixedCols = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goColSizing]
RowCount = 2
TabOrder = 1
TitleFont.Color = clWindowText
end
object OpenDialog1: TOpenDialog
Title = 'Open Schema File'
DefaultExt = '.sch'
FileName = '*.sch'
Filter = 'Schema Files (*.sch)|*.sch|All Files (*.*)|*.*'
InitialDir = 'c:\cache\Data'
left = 232
top = 136
end
object OpenDialog2: TOpenDialog
Title = 'Open CSV File'
DefaultExt = '.csv'
FileName = '*.csv'
Filter = 'CSV Files (*.csv)|*.csv|All Files (*.*)|*.*'
InitialDir = 'c:\cache\data'
left = 232
top = 200
end
end

137
components/systools/examples/grid_fill/gridfil0.pas Normal file
View File

@@ -0,0 +1,137 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit gridfil0;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ExtCtrls,
StTxtDat;
type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
StringGrid1: TStringGrid;
Button2: TButton;
OpenDialog1: TOpenDialog;
OpenDialog2: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
procedure ClearGrid(ClearCaptions: Boolean);
procedure FillCaptions;
procedure FillCells;
{ Private declarations }
public
Schema : TStTextDataSchema;
DataSet : TStTextDataRecordSet;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.ClearGrid(ClearCaptions : Boolean);
var
i : Integer;
begin
if ClearCaptions then
StringGrid1.Rows[0].Clear;
for i := 1 to Pred(StringGrid1.RowCount) do
StringGrid1.Rows[i].Clear;
end;
procedure TForm1.FillCaptions;
begin
StringGrid1.ColCount := Schema.Captions.Count;
StringGrid1.Rows[0].Assign(Schema.Captions);
end;
procedure TForm1.FillCells;
var
i : Integer;
begin
StringGrid1.RowCount := DataSet.Count + 1;
i := 1;
DataSet.First;
while not DataSet.EOF do begin
StringGrid1.Rows[i].Assign(DataSet.CurrentRecord.Values);
DataSet.Next;
Inc(i);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
ClearGrid(True);
Schema.Free;
Schema := TStTextDataSchema.Create;
Schema.LoadFromFile(OpenDialog1.FileName);
FillCaptions;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if OpenDialog2.Execute then begin
ClearGrid(False);
DataSet.Free;
DataSet := TStTextDataRecordSet.Create;
DataSet.Schema := Schema;
DataSet.LoadFromFile(OpenDialog2.FileName);
FillCells;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Schema.Free;
DataSet.Free;
end;
end.

84
components/systools/examples/grid_fill/gridfill.lpi Normal file
View File

@@ -0,0 +1,84 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="gridfill"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="gridfill.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="GridFill"/>
</Unit0>
<Unit1>
<Filename Value="gridfil0.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="gridfill"/>
</Target>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

43
components/systools/examples/grid_fill/gridfill.lpr Normal file
View File

@@ -0,0 +1,43 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program GridFill;
uses
Interfaces,
Forms, lclversion,
gridfil0 in 'gridfil0.pas' {Form1};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

190
components/systools/examples/patterns/chain.lfm Normal file
View File

@@ -0,0 +1,190 @@
object ChainForm: TChainForm
Left = 731
Height = 199
Top = 301
Width = 385
BorderStyle = bsDialog
Caption = 'The Chain Test Form'
ClientHeight = 199
ClientWidth = 385
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Panel2: TPanel
Left = 0
Height = 137
Top = 56
Width = 385
BevelOuter = bvNone
ClientHeight = 137
ClientWidth = 385
TabOrder = 0
object Ch1Lbl: TLabel
Left = 16
Height = 15
Top = 8
Width = 64
Caption = 'Handle < 10'
ParentColor = False
end
object Ch2Lbl: TLabel
Left = 16
Height = 15
Top = 32
Width = 53
Caption = 'Handle 10'
ParentColor = False
end
object Ch3Lbl: TLabel
Left = 16
Height = 15
Top = 56
Width = 64
Caption = 'Handle Odd'
ParentColor = False
end
object Ch4Lbl: TLabel
Left = 16
Height = 15
Top = 80
Width = 67
Caption = 'Handle >100'
ParentColor = False
end
object Ch5Lbl: TLabel
Left = 16
Height = 15
Top = 104
Width = 83
Caption = 'Default Handler'
ParentColor = False
end
object Ch1Value: TEdit
Left = 120
Height = 23
Top = 8
Width = 50
Enabled = False
TabOrder = 0
end
object Ch2Value: TEdit
Left = 120
Height = 23
Top = 32
Width = 50
Enabled = False
TabOrder = 1
end
object Ch3Value: TEdit
Left = 120
Height = 23
Top = 56
Width = 50
Enabled = False
TabOrder = 2
end
object Ch4Value: TEdit
Left = 120
Height = 23
Top = 80
Width = 50
Enabled = False
TabOrder = 3
end
object Ch5Value: TEdit
Left = 120
Height = 23
Top = 104
Width = 50
Enabled = False
TabOrder = 4
end
object Ch1Msg: TEdit
Left = 170
Height = 23
Top = 8
Width = 200
Enabled = False
TabOrder = 5
end
object Ch2Msg: TEdit
Left = 170
Height = 23
Top = 32
Width = 200
Enabled = False
TabOrder = 6
end
object Ch3Msg: TEdit
Left = 170
Height = 23
Top = 56
Width = 200
Enabled = False
TabOrder = 7
end
object Ch4Msg: TEdit
Left = 170
Height = 23
Top = 80
Width = 200
Enabled = False
TabOrder = 8
end
object Ch5Msg: TEdit
Left = 170
Height = 23
Top = 104
Width = 200
Enabled = False
TabOrder = 9
end
end
object Panel1: TPanel
Left = 0
Height = 49
Top = 0
Width = 385
ClientHeight = 49
ClientWidth = 385
TabOrder = 1
object RadioButton1: TRadioButton
Left = 8
Height = 19
Top = 14
Width = 78
Caption = 'Hot Potato'
Checked = True
OnClick = RadioButton1Click
TabOrder = 0
TabStop = True
end
object RadioButton2: TRadioButton
Left = 104
Height = 19
Top = 14
Width = 64
Caption = 'Additive'
OnClick = RadioButton2Click
TabOrder = 1
end
object InputValue: TEdit
Left = 200
Height = 23
Top = 12
Width = 73
TabOrder = 2
end
object Start: TButton
Left = 288
Height = 25
Top = 11
Width = 82
Caption = 'Start'
OnClick = StartClick
TabOrder = 3
end
end
end

304
components/systools/examples/patterns/chain.pas Normal file
View File

@@ -0,0 +1,304 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Chain;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
TInputData = class
public
{ Public declarations }
InData : integer;
end;
type
TOutputData = class
public
{ Public declarations }
OutData : integer;
end;
type
TChainForm = class(TForm)
Panel2: TPanel;
Ch1Lbl: TLabel;
Ch2Lbl: TLabel;
Ch3Lbl: TLabel;
Ch4Lbl: TLabel;
Ch5Lbl: TLabel;
Ch1Value: TEdit;
Ch2Value: TEdit;
Ch3Value: TEdit;
Ch4Value: TEdit;
Ch5Value: TEdit;
Ch1Msg: TEdit;
Ch2Msg: TEdit;
Ch3Msg: TEdit;
Ch4Msg: TEdit;
Ch5Msg: TEdit;
Panel1: TPanel;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
InputValue: TEdit;
Start: TButton;
procedure RadioButton1Click(Sender: TObject);
procedure RadioButton2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StartClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
// Code for the chain
TheChain : TStChain;
procedure Chain1Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain2Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain3Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain4Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure Chain5Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
procedure ClearScreen;
public
{ Public declarations }
end;
var
ChainForm: TChainForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
var
ChainPotato : Boolean;
TheChain: TStChain;
procedure TChainForm.RadioButton1Click(Sender: TObject);
begin
if (RadioButton1.Checked) then begin
Ch1Lbl.Caption := 'Handle < 10';
Ch2Lbl.Caption := 'Handle 10';
Ch3Lbl.Caption := 'Handle Odd';
Ch4Lbl.Caption := 'Handle > 100';
Ch5Lbl.Caption := 'Default Handler';
ChainPotato := true;
ClearScreen;
end;
end;
procedure TChainForm.RadioButton2Click(Sender: TObject);
begin
if (RadioButton2.Checked) then begin
Ch1Lbl.Caption := 'Add 10';
Ch2Lbl.Caption := 'Multiply by 10';
Ch3Lbl.Caption := 'Add 3';
Ch4Lbl.Caption := 'Subtract 4';
Ch5Lbl.Caption := 'Zero out';
ChainPotato := false;
ClearScreen;
end;
end;
procedure TChainForm.Chain1Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if (myInputData.InData < 10) then begin
Ch1Value.text := Inttostr(myInputData.InData);
Ch1Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch1Value.text := ' ';
Ch1Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData + 10;
Ch1Value.text := Inttostr(myOutputData.OutData);
Ch1Msg.Text := 'Added 10';
end
end;
procedure TChainForm.Chain2Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if (myInputData.InData = 10) then begin
Ch2Value.text := Inttostr(myInputData.InData);
Ch2Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch2Value.text := ' ';
Ch2Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData * 10;
Ch2Value.text := Inttostr(myOutputData.OutData);
Ch2Msg.Text := 'Mulitplied by 10';
end
end;
procedure TChainForm.Chain3Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if odd(myInputData.InData) then begin
Ch3Value.text := Inttostr(myInputData.InData);
Ch3Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch3Value.text := ' ';
Ch3Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData + 3;
Ch3Value.text := Inttostr(myOutputData.OutData);
Ch3Msg.Text := 'Added 3';
end
end;
procedure TChainForm.Chain4Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
if (myInputData.InData > 100) then begin
Ch4Value.text := Inttostr(myInputData.InData);
Ch4Msg.Text := 'I handled it';
aStopNow := true;
end else begin
Ch4Value.text := ' ';
Ch4Msg.Text := 'Not here';
aStopNow := false;
end
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := myOutputData.OutData -4;
Ch4Value.text := Inttostr(myOutputData.OutData);
Ch4Msg.Text := 'Subtracted 4';
end
end;
procedure TChainForm.Chain5Proc(aInputData, aResultData : TObject; var aStopNow : boolean);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
if (ChainPotato) then begin
myInputData := TInputData(aInputData);
Ch5Value.text := Inttostr(myInputData.InData);
Ch5Msg.Text := 'I handled it';
aStopNow := true;
end else begin
myOutputData := TOutputData(aResultData);
myOutputData.OutData := 0;
Ch5Value.text := Inttostr(myOutputData.OutData);
Ch5Msg.Text := 'Zeroed out';
end
end;
procedure TChainForm.FormCreate(Sender: TObject);
begin
ChainPotato := true;
TheChain:= TStChain.create;
TheChain.Add(Chain1Proc);
TheChain.Add(Chain2Proc);
TheChain.Add(Chain3Proc);
TheChain.Add(Chain4Proc);
TheChain.Add(Chain5Proc);
end;
procedure TChainForm.StartClick(Sender: TObject);
var
myInputData : TInputData;
myOutputData : TOutputData;
begin
myInputData := nil;
myOutputData := nil;
try
myInputData := TInputData.Create;
myOutputData := TOutputData.Create;
myInputData.InData := Strtoint(InputValue.Text);
myOutputData.OutData := Strtoint(InputValue.Text);
ClearScreen;
TheChain.Handle(myInputData, myOutputData);
finally;
myInputData.free;
myOutputData.free;
end;
end;
procedure TChainForm.ClearScreen;
begin
Ch1Value.text := ' ';
Ch1Msg.Text := ' ';
Ch2Value.text := ' ';
Ch2Msg.Text := ' ';
Ch3Value.text := ' ';
Ch3Msg.Text := ' ';
Ch4Value.text := ' ';
Ch4Msg.Text := ' ';
Ch5Value.text := ' ';
Ch5Msg.Text := ' ';
end;
procedure TChainForm.FormDestroy(Sender: TObject);
begin
TheChain.free;
end;
end.

284
components/systools/examples/patterns/medtr.lfm Normal file
View File

@@ -0,0 +1,284 @@
object MediatorForm: TMediatorForm
Left = 661
Height = 278
Top = 112
Width = 561
BorderStyle = bsDialog
Caption = 'The Mediator Test Form'
ClientHeight = 278
ClientWidth = 561
Color = clBtnFace
Font.Color = clWindowText
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 16
Height = 114
Top = 152
Width = 232
BevelOuter = bvNone
ClientHeight = 114
ClientWidth = 232
TabOrder = 0
object ASelectBox: TCheckBox
Left = 8
Height = 19
Top = 8
Width = 60
Caption = 'A Event'
TabOrder = 0
end
object BSelectBox: TCheckBox
Left = 7
Height = 19
Top = 28
Width = 59
Caption = 'B Event'
TabOrder = 1
end
object CSelectBox: TCheckBox
Left = 8
Height = 19
Top = 48
Width = 60
Caption = 'C Event'
TabOrder = 2
end
object DSelectBox: TCheckBox
Left = 8
Height = 19
Top = 68
Width = 60
Caption = 'D Event'
TabOrder = 3
end
object ESelectBox: TCheckBox
Left = 8
Height = 19
Top = 88
Width = 58
Caption = 'E Event'
TabOrder = 4
end
object Start: TButton
Left = 120
Height = 49
Top = 28
Width = 82
Caption = 'Start'
OnClick = StartClick
TabOrder = 5
end
end
object Panel2: TPanel
Left = 280
Height = 114
Top = 152
Width = 272
BevelOuter = bvNone
ClientHeight = 114
ClientWidth = 272
TabOrder = 1
object Ch1Lbl: TLabel
Left = 16
Height = 15
Top = 8
Width = 51
Caption = 'Handler 1'
ParentColor = False
end
object Ch2Lbl: TLabel
Left = 16
Height = 15
Top = 32
Width = 51
Caption = 'Handler 2'
ParentColor = False
end
object Ch3Lbl: TLabel
Left = 16
Height = 15
Top = 56
Width = 51
Caption = 'Handler 3'
ParentColor = False
end
object Ch4Lbl: TLabel
Left = 16
Height = 15
Top = 80
Width = 51
Caption = 'Handler 4'
ParentColor = False
end
object H1Result: TLabel
Left = 70
Height = 1
Top = 8
Width = 1
ParentColor = False
end
object H2Result: TLabel
Left = 70
Height = 1
Top = 32
Width = 1
ParentColor = False
end
object H3Result: TLabel
Left = 70
Height = 1
Top = 56
Width = 1
ParentColor = False
end
object H4Result: TLabel
Left = 70
Height = 1
Top = 80
Width = 1
ParentColor = False
end
end
object Panel3: TPanel
Left = 0
Height = 144
Top = 0
Width = 552
BevelOuter = bvNone
ClientHeight = 144
ClientWidth = 552
Font.Color = clWindowText
ParentFont = False
TabOrder = 2
object AEvents: TRadioGroup
Left = 16
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event A'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 0
end
object BEvents: TRadioGroup
Left = 120
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event B'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 1
end
object CEvents: TRadioGroup
Left = 216
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event C'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 2
end
object DEvents: TRadioGroup
Left = 328
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event D'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 3
end
object EEvents: TRadioGroup
Left = 440
Height = 113
Top = 16
Width = 96
AutoFill = True
Caption = 'Event E'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 93
ClientWidth = 92
ItemIndex = 4
Items.Strings = (
'Handler 1'
'Handler 2'
'Handler 3'
'Handler 4'
'None'
)
TabOrder = 4
end
end
end

169
components/systools/examples/patterns/medtr.pas Normal file
View File

@@ -0,0 +1,169 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Medtr;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
{ TMediatorForm }
TMediatorForm = class(TForm)
Panel1: TPanel;
ASelectBox: TCheckBox;
BSelectBox: TCheckBox;
CSelectBox: TCheckBox;
DSelectBox: TCheckBox;
ESelectBox: TCheckBox;
Start: TButton;
Panel2: TPanel;
Ch1Lbl: TLabel;
Ch2Lbl: TLabel;
Ch3Lbl: TLabel;
Ch4Lbl: TLabel;
Panel3: TPanel;
AEvents: TRadioGroup;
H1Result: TLabel;
H2Result: TLabel;
H3Result: TLabel;
H4Result: TLabel;
BEvents: TRadioGroup;
CEvents: TRadioGroup;
DEvents: TRadioGroup;
EEvents: TRadioGroup;
procedure StartClick(Sender: TObject);
private
TheMediator: TStMediator;
procedure MediatedFunction1(aInputData, aResultData : TObject);
procedure MediatedFunction2(aInputData, aResultData : TObject);
procedure MediatedFunction3(aInputData, aResultData : TObject);
procedure MediatedFunction4(aInputData, aResultData : TObject);
procedure SetupMediator(Letter: String; Which: TRadioGroup);
{ Private declarations }
public
{ Public declarations }
end;
var
MediatorForm: TMediatorForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TMediatorForm.StartClick(Sender: TObject);
begin
TheMediator := TStMediator.create;
H1Result.Caption := '';
H2Result.Caption := '';
H3Result.Caption := '';
H4Result.Caption := '';
SetupMediator('A', AEvents);
SetupMediator('B', BEvents);
SetupMediator('C', CEvents);
SetupMediator('D', DEvents);
SetupMediator('E', EEvents);
if (ASelectBox.Checked) then
TheMediator.Handle('A', nil, nil);
if (BSelectBox.Checked) then
TheMediator.Handle('B', nil, nil);
if (CSelectBox.Checked) then
TheMediator.Handle('C', nil, nil);
if (DSelectBox.Checked) then
TheMediator.Handle('D', nil, nil);
if (ESelectBox.Checked) then
TheMediator.Handle('E', nil, nil);
TheMediator.free;
end;
procedure TMediatorForm.SetupMediator(Letter: String; Which: TRadioGroup);
begin
If (Which.ItemIndex = 0) then
TheMediator.Add(Letter, MediatedFunction1)
else If (Which.ItemIndex = 1) then
TheMediator.Add(Letter, MediatedFunction2)
else If (Which.ItemIndex = 2) then
TheMediator.Add(Letter, MediatedFunction3)
else If (Which.ItemIndex = 3) then
TheMediator.Add(Letter, MediatedFunction4);
end;
procedure TMediatorForm.MediatedFunction1(aInputData, aResultData : TObject);
begin
H1Result.Caption := 'I worked';
end;
procedure TMediatorForm.MediatedFunction2(aInputData, aResultData : TObject);
begin
H2Result.Caption := 'I worked';
end;
procedure TMediatorForm.MediatedFunction3(aInputData, aResultData : TObject);
begin
H3Result.Caption := 'I worked';
end;
procedure TMediatorForm.MediatedFunction4(aInputData, aResultData : TObject);
begin
H4Result.Caption := 'I worked';
end;
procedure InitUnit;
begin
end;
procedure DoneUnit;
begin
end;
initialization
InitUnit;
finalization
DoneUnit;
end.

86
components/systools/examples/patterns/observer.lfm Normal file
View File

@@ -0,0 +1,86 @@
object ObserverForm: TObserverForm
Left = 484
Height = 179
Top = 295
Width = 207
BorderStyle = bsDialog
Caption = 'The Observer Test Form'
ClientHeight = 179
ClientWidth = 207
Color = clBtnFace
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 179
Top = 0
Width = 207
Align = alClient
ClientHeight = 179
ClientWidth = 207
Font.Color = clWindowText
ParentFont = False
TabOrder = 0
object Label1: TLabel
Left = 19
Height = 15
Top = 16
Width = 45
Caption = 'Caption:'
ParentColor = False
end
object Button1: TButton
Left = 48
Height = 25
Top = 40
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button1Click
TabOrder = 0
end
object Edit1: TEdit
Left = 72
Height = 23
Top = 12
Width = 105
OnChange = Edit1Change
TabOrder = 1
Text = 'Caption for Buttons'
end
object Button2: TButton
Left = 47
Height = 25
Top = 72
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button2Click
TabOrder = 2
end
object Button3: TButton
Left = 48
Height = 25
Top = 104
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button3Click
TabOrder = 3
end
object Button4: TButton
Left = 47
Height = 25
Top = 136
Width = 130
AutoSize = True
Caption = 'Caption for Buttons'
OnClick = Button4Click
TabOrder = 4
end
end
end

143
components/systools/examples/patterns/observer.pas Normal file
View File

@@ -0,0 +1,143 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Observer;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
TObserverForm = class(TForm)
Panel1: TPanel;
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Edit1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
// Code for the observer
{ Private declarations }
public
TheObserver: TStObserver;
procedure ReceiveNotification1(WhatChanged: TObject);
procedure ReceiveNotification2(WhatChanged: TObject);
procedure ReceiveNotification3(WhatChanged: TObject);
procedure ReceiveNotification4(WhatChanged: TObject);
{ Public declarations }
end;
var
ObserverForm: TObserverForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TObserverForm.Edit1Change(Sender: TObject);
begin
TheObserver.Notify(TObject(Edit1.Text));
end;
procedure TObserverForm.ReceiveNotification1(WhatChanged: TObject);
begin
Button1.Caption := String(WhatChanged);
end;
procedure TObserverForm.ReceiveNotification2(WhatChanged: TObject);
begin
Button2.Caption := String(WhatChanged);
end;
procedure TObserverForm.ReceiveNotification3(WhatChanged: TObject);
begin
Button3.Caption := String(WhatChanged);
end;
procedure TObserverForm.ReceiveNotification4(WhatChanged: TObject);
begin
Button4.Caption := String(WhatChanged);
end;
procedure TObserverForm.Button1Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 1';
end;
procedure TObserverForm.Button2Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 2';
end;
procedure TObserverForm.Button3Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 3';
end;
procedure TObserverForm.Button4Click(Sender: TObject);
begin
Edit1.Text:= 'Reset 4';
end;
procedure TObserverForm.FormCreate(Sender: TObject);
begin
TheObserver := TStObserver.Create;
TheObserver.Add(ReceiveNotification1);
TheObserver.Add(ReceiveNotification2);
TheObserver.Add(ReceiveNotification3);
TheObserver.Add(ReceiveNotification4);
end;
procedure TObserverForm.FormDestroy(Sender: TObject);
begin
TheObserver.Free;
end;
end.

104
components/systools/examples/patterns/patntest.lpi Normal file
View File

@@ -0,0 +1,104 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="patntest"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="6">
<Unit0>
<Filename Value="patntest.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="PatnTest"/>
</Unit0>
<Unit1>
<Filename Value="root.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit1>
<Unit2>
<Filename Value="chain.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="Chain"/>
</Unit2>
<Unit3>
<Filename Value="medtr.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit3>
<Unit4>
<Filename Value="observer.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
<UnitName Value="Observer"/>
</Unit4>
<Unit5>
<Filename Value="singlton.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit5>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="patntest"/>
</Target>
<SearchPaths>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

47
components/systools/examples/patterns/patntest.lpr Normal file
View File

@@ -0,0 +1,47 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
program PatnTest;
uses
Interfaces,
Forms, lclversion,
Observer in 'Observer.pas' {ObserverForm},
Chain in 'Chain.pas' {ChainForm},
Medtr in 'Medtr.pas' {MediatorForm},
Root in 'Root.pas' {RootForm},
Singlton in 'Singlton.pas' {SingletonForm};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TRootForm, RootForm);
Application.Run;
end.

92
components/systools/examples/patterns/root.lfm Normal file
View File

@@ -0,0 +1,92 @@
object RootForm: TRootForm
Left = 241
Height = 173
Top = 127
Width = 304
BorderStyle = bsDialog
Caption = 'Pick Your Example'
ClientHeight = 173
ClientWidth = 304
Color = clBtnFace
Font.Color = clWindowText
LCLVersion = '1.9.0.0'
Scaled = False
object ObserverBtn: TButton
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
Left = 116
Height = 25
Top = 16
Width = 73
AutoSize = True
Caption = 'Observer'
OnClick = ObserverBtnClick
TabOrder = 0
end
object MediatorBtn: TButton
AnchorSideLeft.Control = ObserverBtn
AnchorSideTop.Control = ChainBtn
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = ObserverBtn
AnchorSideRight.Side = asrBottom
Left = 116
Height = 25
Top = 70
Width = 73
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 2
Caption = 'Mediator'
OnClick = MediatorBtnClick
TabOrder = 1
end
object ChainBtn: TButton
AnchorSideLeft.Control = ObserverBtn
AnchorSideTop.Control = ObserverBtn
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = ObserverBtn
AnchorSideRight.Side = asrBottom
Left = 116
Height = 25
Top = 43
Width = 73
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 2
Caption = 'Chain'
OnClick = ChainBtnClick
TabOrder = 2
end
object SingletonBtn: TButton
AnchorSideLeft.Control = ObserverBtn
AnchorSideTop.Control = MediatorBtn
AnchorSideTop.Side = asrBottom
AnchorSideRight.Control = ObserverBtn
AnchorSideRight.Side = asrBottom
Left = 116
Height = 25
Top = 97
Width = 73
Anchors = [akTop, akLeft, akRight]
AutoSize = True
BorderSpacing.Top = 2
Caption = 'Singleton'
OnClick = SingletonBtnClick
TabOrder = 3
end
object ExitBtn: TButton
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
AnchorSideTop.Control = SingletonBtn
AnchorSideTop.Side = asrBottom
Left = 130
Height = 25
Top = 138
Width = 44
AutoSize = True
BorderSpacing.Top = 16
Caption = '&Exit'
OnClick = ExitBtnClick
TabOrder = 4
end
end

101
components/systools/examples/patterns/root.pas Normal file
View File

@@ -0,0 +1,101 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Root;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TRootForm = class(TForm)
ObserverBtn: TButton;
MediatorBtn: TButton;
ChainBtn: TButton;
SingletonBtn: TButton;
ExitBtn: TButton;
procedure ObserverBtnClick(Sender: TObject);
procedure ChainBtnClick(Sender: TObject);
procedure MediatorBtnClick(Sender: TObject);
procedure SingletonBtnClick(Sender: TObject);
procedure ExitBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
RootForm: TRootForm;
implementation
uses Chain, Medtr, Observer, Singlton;
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TRootForm.ObserverBtnClick(Sender: TObject);
begin
Application.CreateForm(TObserverForm, ObserverForm);
ObserverForm.ShowModal;
end;
procedure TRootForm.ChainBtnClick(Sender: TObject);
begin
Application.CreateForm(TChainForm, ChainForm);
ChainForm.ShowModal;
end;
procedure TRootForm.MediatorBtnClick(Sender: TObject);
begin
Application.CreateForm(TMediatorForm, MediatorForm);
MediatorForm.ShowModal;
end;
procedure TRootForm.SingletonBtnClick(Sender: TObject);
begin
Application.CreateForm(TSingletonForm, SingletonForm);
SingletonForm.ShowModal;
end;
procedure TRootForm.ExitBtnClick(Sender: TObject);
begin
Close;
end;
end.

213
components/systools/examples/patterns/singlton.lfm Normal file
View File

@@ -0,0 +1,213 @@
object SingletonForm: TSingletonForm
Left = 608
Height = 139
Top = 122
Width = 440
AutoSize = True
BorderStyle = bsDialog
Caption = 'The Singleton Test Form'
ClientHeight = 139
ClientWidth = 440
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 0
Height = 128
Top = 8
Width = 440
BevelOuter = bvNone
ClientHeight = 128
ClientWidth = 440
TabOrder = 0
object Label1: TLabel
Left = 88
Height = 15
Top = 8
Width = 89
Caption = 'Singleton Count:'
ParentColor = False
end
object Display1: TEdit
Left = 288
Height = 23
Top = 40
Width = 45
TabOrder = 0
Text = '(empty)'
end
object CnR1: TButton
Left = 220
Height = 25
Top = 40
Width = 52
AutoSize = True
Caption = 'Read'
OnClick = CnR1Click
TabOrder = 1
end
object Set1: TButton
Left = 344
Height = 25
Top = 40
Width = 74
AutoSize = True
Caption = 'Set Value'
OnClick = Set1Click
TabOrder = 2
end
object CnR2: TButton
Left = 220
Height = 25
Top = 64
Width = 52
AutoSize = True
Caption = 'Read'
OnClick = CnR2Click
TabOrder = 3
end
object Display2: TEdit
Left = 288
Height = 23
Top = 64
Width = 45
TabOrder = 4
Text = '(empty)'
end
object Set2: TButton
Left = 344
Height = 25
Top = 64
Width = 74
AutoSize = True
Caption = 'Set Value'
OnClick = Set2Click
TabOrder = 5
end
object CnR3: TButton
Left = 220
Height = 25
Top = 88
Width = 52
AutoSize = True
Caption = 'Read'
OnClick = CnR3Click
TabOrder = 6
end
object Display3: TEdit
Left = 288
Height = 23
Top = 88
Width = 45
TabOrder = 7
Text = '(empty)'
end
object Set3: TButton
Left = 344
Height = 25
Top = 88
Width = 74
AutoSize = True
Caption = 'Set Value'
OnClick = Set3Click
TabOrder = 8
end
object Create1: TButton
Left = 20
Height = 25
Top = 40
Width = 60
AutoSize = True
Caption = 'Create'
OnClick = Create1Click
TabOrder = 9
end
object Create2: TButton
Left = 20
Height = 25
Top = 64
Width = 60
AutoSize = True
Caption = 'Create'
OnClick = Create2Click
TabOrder = 10
end
object Create3: TButton
Left = 20
Height = 25
Top = 88
Width = 60
AutoSize = True
Caption = 'Create'
OnClick = Create3Click
TabOrder = 11
end
object Free1: TButton
Left = 160
Height = 25
Top = 40
Width = 48
AutoSize = True
Caption = 'Free'
OnClick = Free1Click
TabOrder = 12
end
object Free2: TButton
Left = 160
Height = 25
Top = 64
Width = 48
AutoSize = True
Caption = 'Free'
OnClick = Free2Click
TabOrder = 13
end
object Free3: TButton
Left = 160
Height = 25
Top = 88
Width = 48
AutoSize = True
Caption = 'Free'
OnClick = Free3Click
TabOrder = 14
end
object Counter: TEdit
Left = 184
Height = 23
Top = 4
Width = 33
Enabled = False
TabOrder = 15
Text = '0'
end
object Ref1: TEdit
Left = 94
Height = 23
Top = 40
Width = 50
Enabled = False
TabOrder = 16
Text = 'ref is nil'
end
object Ref2: TEdit
Left = 94
Height = 23
Top = 64
Width = 50
Enabled = False
TabOrder = 17
Text = 'ref is nil'
end
object Ref3: TEdit
Left = 94
Height = 23
Top = 88
Width = 50
Enabled = False
TabOrder = 18
Text = 'ref is nil'
end
end
end

237
components/systools/examples/patterns/singlton.pas Normal file
View File

@@ -0,0 +1,237 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit Singlton;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StPtrns, ExtCtrls;
type
TSingleData = class(TStSingleton)
public
{ Public declarations }
TheData : integer;
end;
type
TSingletonForm = class(TForm)
Panel1: TPanel;
Display1: TEdit;
CnR1: TButton;
Set1: TButton;
CnR2: TButton;
Display2: TEdit;
Set2: TButton;
CnR3: TButton;
Display3: TEdit;
Set3: TButton;
Create1: TButton;
Create2: TButton;
Create3: TButton;
Free1: TButton;
Free2: TButton;
Free3: TButton;
Counter: TEdit;
Label1: TLabel;
Ref1: TEdit;
Ref2: TEdit;
Ref3: TEdit;
procedure CnR1Click(Sender: TObject);
procedure CnR2Click(Sender: TObject);
procedure CnR3Click(Sender: TObject);
procedure Set1Click(Sender: TObject);
procedure Set2Click(Sender: TObject);
procedure Set3Click(Sender: TObject);
procedure Create1Click(Sender: TObject);
procedure Create2Click(Sender: TObject);
procedure Create3Click(Sender: TObject);
procedure Free1Click(Sender: TObject);
procedure Free2Click(Sender: TObject);
procedure Free3Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure UpdateDisplays;
public
{ Public declarations }
end;
var
SingletonForm: TSingletonForm;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
var
SingleCounter : integer;
MySingleton1: TSingleData;
MySingleton2: TSingleData;
MySingleton3: TSingleData;
procedure TSingletonForm.CnR1Click(Sender: TObject);
begin
if (MySingleton1 <> nil) then
Display1.Text := IntToStr(MySingleton1.TheData);
end;
procedure TSingletonForm.CnR2Click(Sender: TObject);
begin
if (MySingleton2 <> nil) then
Display2.Text := IntToStr(MySingleton2.TheData);
end;
procedure TSingletonForm.CnR3Click(Sender: TObject);
begin
if (MySingleton3 <> nil) then
Display3.Text := IntToStr(MySingleton3.TheData);
end;
procedure TSingletonForm.Set1Click(Sender: TObject);
begin
if (MySingleton1 = nil) then
exit;
MySingleton1.TheData := Strtoint(Display1.text);
UpdateDisplays;
end;
procedure TSingletonForm.Set2Click(Sender: TObject);
begin
if (MySingleton2 = nil) then
exit;
MySingleton2.TheData := Strtoint(Display2.text);
UpdateDisplays;
end;
procedure TSingletonForm.Set3Click(Sender: TObject);
begin
if (MySingleton3 = nil) then
exit;
MySingleton3.TheData := Strtoint(Display3.text);
UpdateDisplays;
end;
procedure TSingletonForm.Create1Click(Sender: TObject);
begin
if (MySingleton1 = nil) then begin
MySingleton1 := TSingleData.create;
SingleCounter := SingleCounter + 1;
Counter.Text := Inttostr(SingleCounter);
Display1.Text := IntToStr(MySingleton1.TheData);
Ref1.Text := 'ref exists';
end
end;
procedure TSingletonForm.Create2Click(Sender: TObject);
begin
if (MySingleton2 = nil) then begin
MySingleton2 := TSingleData.create;
SingleCounter := SingleCounter + 1;
Counter.Text := Inttostr(SingleCounter);
Display2.Text := IntToStr(MySingleton2.TheData);
Ref2.Text := 'ref exists';
end
end;
procedure TSingletonForm.Create3Click(Sender: TObject);
begin
if (MySingleton3 = nil) then begin
MySingleton3 := TSingleData.create;
SingleCounter := SingleCounter + 1;
Counter.Text := Inttostr(SingleCounter);
Display3.Text := IntToStr(MySingleton3.TheData);
Ref3.Text := 'ref exists';
end
end;
procedure TSingletonForm.Free1Click(Sender: TObject);
begin
if (MySingleton1 = nil) then
exit;
MySingleton1.free;
MySingleton1 := nil;
if (SingleCounter > 0) then
SingleCounter := SingleCounter - 1;
Counter.Text := Inttostr(SingleCounter);
Display1.Text := '(empty)';
Ref1.Text := 'ref is nil';
end;
procedure TSingletonForm.Free2Click(Sender: TObject);
begin
if (MySingleton2 = nil) then
exit;
MySingleton2.free;
MySingleton2 := nil;
if (SingleCounter > 0) then
SingleCounter := SingleCounter - 1;
Counter.Text := Inttostr(SingleCounter);
Display2.Text := '(empty)';
Ref2.Text := 'ref is nil';
end;
procedure TSingletonForm.Free3Click(Sender: TObject);
begin
if (MySingleton3 = nil) then
exit;
MySingleton3.free;
MySingleton3 := nil;
if (SingleCounter > 0) then
SingleCounter := SingleCounter - 1;
Counter.Text := Inttostr(SingleCounter);
Display3.Text := '(empty)';
Ref3.Text := 'ref is nil';
end;
procedure TSingletonForm.FormCreate(Sender: TObject);
begin
SingleCounter := 0;
end;
procedure TSingletonForm.UpdateDisplays;
begin
if (MySingleton1 <> nil) then
Display1.Text := IntToStr(MySingleton1.TheData);
if (MySingleton2 <> nil) then
Display2.Text := IntToStr(MySingleton2.TheData);
if (MySingleton3 <> nil) then
Display3.Text := IntToStr(MySingleton3.TheData);
end;
end.