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

systools: Add windows-specific units to new package laz_systoolswin

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6148 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-01-17 23:58:23 +00:00
parent 133a3b98d7
commit 2f86a4b7f9
41 changed files with 11549 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
components/systools/examples/windows-only/general_log/exgenlog.lpi Normal file
View File

@ -0,0 +1,86 @@
<?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="exgenlog"/>
<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_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="exgenlog.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ExGenLog"/>
</Unit0>
<Unit1>
<Filename Value="exglog1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExGLog1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exgenlog"/>
</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/windows-only/general_log/exgenlog.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 ExGenLog;
uses
Interfaces,
Forms, lclversion,
exglog1 in 'exglog1.pas' {Form1};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

97
components/systools/examples/windows-only/general_log/exglog1.lfm Normal file
View File

@ -0,0 +1,97 @@
object Form1: TForm1
Left = 280
Height = 254
Top = 305
Width = 514
Caption = 'General Log Example'
ClientHeight = 254
ClientWidth = 514
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 192
Height = 15
Top = 107
Width = 71
Caption = 'String to add:'
ParentColor = False
end
object RadioGroup1: TRadioGroup
Left = 193
Height = 57
Top = 22
Width = 289
AutoFill = True
Caption = 'Event Type'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 4
ClientHeight = 37
ClientWidth = 285
Columns = 4
Items.Strings = (
'Apple'
'Orange'
'Lemon'
'Grape'
)
TabOrder = 0
end
object Button1: TButton
Left = 33
Height = 33
Top = 38
Width = 121
Caption = 'Add event to log'
OnClick = Button1Click
TabOrder = 1
end
object Button2: TButton
Left = 32
Height = 33
Top = 110
Width = 121
Caption = 'Add string to log'
OnClick = Button2Click
TabOrder = 2
end
object Edit1: TEdit
Left = 192
Height = 23
Top = 126
Width = 289
TabOrder = 3
end
object Button3: TButton
Left = 32
Height = 33
Top = 182
Width = 121
Caption = 'Dump log'
OnClick = Button3Click
TabOrder = 4
end
object CheckBox1: TCheckBox
Left = 192
Height = 19
Top = 192
Width = 82
Caption = 'Append log'
OnClick = CheckBox1Click
TabOrder = 5
end
object StGeneralLog1: TStGeneralLog
FileName = 'debug.log'
LogFileHeader = 'SysTools General Log'#10#13'============================================================================='#10#13#10#13
WriteMode = wmOverwrite
OnGetLogString = StGeneralLog1GetLogString
left = 400
top = 168
end
end

127
components/systools/examples/windows-only/general_log/exglog1.pas Normal file
View File

@ -0,0 +1,127 @@
(* ***** 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 ExGLog1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, StBase, StGenLog;
const
AppleEvent = 1;
OrangeEvent = 2;
LemonEvent = 3;
GrapeEvent = 4;
UnknownEvent = 5;
type
TForm1 = class(TForm)
RadioGroup1: TRadioGroup;
Button1: TButton;
Button2: TButton;
Edit1: TEdit;
Label1: TLabel;
Button3: TButton;
CheckBox1: TCheckBox;
StGeneralLog1: TStGeneralLog;
procedure CheckBox1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure StGeneralLog1GetLogString(Sender: TObject; const D1, D2, D3,
D4: Integer; var LogString: String);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
if CheckBox1.Checked then
StGeneralLog1.WriteMode := wmAppend
else
StGeneralLog1.WriteMode := wmOverwrite;
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
StGeneralLog1.DumpLog;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
StGeneralLog1.WriteLogString(Edit1.Text);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
case RadioGroup1.ItemIndex of
0 : StGeneralLog1.AddLogEntry(AppleEvent, 0, 0, 0);
1 : StGeneralLog1.AddLogEntry(OrangeEvent, 0, 0, 0);
2 : StGeneralLog1.AddLogEntry(LemonEvent, 0, 0, 0);
3 : StGeneralLog1.AddLogEntry(GrapeEvent, 0, 0, 0);
else
StGeneralLog1.AddLogEntry(UnknownEvent, 0, 0, 0);
end;
end;
procedure TForm1.StGeneralLog1GetLogString(Sender: TObject; const D1, D2,
D3, D4: Integer; var LogString: String);
begin
case D1 of
AppleEvent : LogString := 'AppleEvent';
OrangeEvent : LogString := 'OrangeEvent';
LemonEvent : LogString := 'LemonEvent';
GrapeEvent : LogString := 'GrapeEvent';
else
LogString := 'UnknownEvent';
end
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
StGeneralLog1.FileName := ExtractFilePath(Application.ExeName) + 'exgenlog.log';
end;
end.

90
components/systools/examples/windows-only/nt_log/exnlog1.lfm Normal file
View File

@ -0,0 +1,90 @@
object Form1: TForm1
Left = 205
Height = 310
Top = 155
Width = 421
Caption = 'NT Log Example'
ClientHeight = 310
ClientWidth = 421
Color = clBtnFace
Font.Color = clWindowText
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 159
Height = 1
Top = 72
Width = 1
ParentColor = False
end
object Label2: TLabel
Left = 159
Height = 1
Top = 112
Width = 1
ParentColor = False
end
object Label3: TLabel
Left = 159
Height = 1
Top = 152
Width = 1
ParentColor = False
end
object Label4: TLabel
Left = 64
Height = 15
Top = 72
Width = 86
Caption = 'Number of logs:'
ParentColor = False
end
object Label5: TLabel
Left = 64
Height = 15
Top = 112
Width = 74
Caption = 'Record count:'
ParentColor = False
end
object Label6: TLabel
Left = 64
Height = 15
Top = 152
Width = 71
Caption = 'Records read:'
ParentColor = False
end
object Label7: TLabel
Left = 241
Height = 15
Top = 45
Width = 85
Caption = 'Logs on system:'
ParentColor = False
end
object Button1: TButton
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
Left = 165
Height = 25
Top = 256
Width = 91
AutoSize = True
Caption = 'Get Log Info'
OnClick = Button1Click
TabOrder = 0
end
object ListBox1: TListBox
Left = 240
Height = 129
Top = 64
Width = 161
ItemHeight = 0
TabOrder = 1
end
object EL: TStNTEventLog
LogName = 'Application'
left = 24
top = 24
end
end

88
components/systools/examples/windows-only/nt_log/exnlog1.pas Normal file
View File

@ -0,0 +1,88 @@
(* ***** 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 ExNLog1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, StBase, StNTLog;
type
TForm1 = class(TForm)
Button1: TButton;
EL: TStNTEventLog;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
ListBox1: TListBox;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
procedure MyOnRead(Sender : TObject; const EventRec : TStNTEventLogRec; var Abort : Boolean);
public
{ Public declarations }
end;
var
Form1: TForm1;
ReadCount : DWORD = 0;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.MyOnRead(Sender : TObject; const EventRec : TStNTEventLogRec; var Abort : Boolean);
begin
Inc(ReadCount);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
I : Integer;
begin
EL.OnReadRecord := MyOnRead;
Label1.Caption := IntToStr(EL.LogCount);
for I := 0 to EL.LogCount-1 do
Listbox1.Items.Add(EL.Logs[I]);
Label2.Caption := IntToStr(EL.RecordCount);
EL.ReadLog(True);
Label3.Caption := IntToStr(ReadCount);
end;
end.

83
components/systools/examples/windows-only/nt_log/exntlog.lpi Normal file
View File

@ -0,0 +1,83 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="exntlog"/>
<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_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="exntlog.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ExNTLog"/>
</Unit0>
<Unit1>
<Filename Value="exnlog1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExNLog1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exntlog"/>
</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/windows-only/nt_log/exntlog.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 ExNTLog;
uses
Interfaces,
Forms, lclversion,
exnlog1 in 'exnlog1.pas' {Form1};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

86
components/systools/examples/windows-only/sort/exsort.lpi Normal file
View File

@ -0,0 +1,86 @@
<?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="exsort"/>
<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_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="exsort.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ExSort"/>
</Unit0>
<Unit1>
<Filename Value="exsortu.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="STDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExSortU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exsort"/>
</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/windows-only/sort/exsort.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 ExSort;
uses
Interfaces,
Forms, lclversion,
exsortu in 'exsortu.pas' {TSTDlg};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

88
components/systools/examples/windows-only/sort/exsortu.lfm Normal file
View File

@ -0,0 +1,88 @@
object STDlg: TSTDlg
Left = 250
Height = 273
Top = 156
Width = 428
Caption = 'StSorter Example'
ClientHeight = 273
ClientWidth = 428
Color = clBtnFace
Font.Color = clWindowText
OnActivate = FormActivate
ShowHint = True
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 346
Height = 15
Top = 28
Width = 76
Caption = 'Items (1..5000)'
ParentColor = False
end
object LB1: TListBox
Left = 8
Height = 247
Hint = 'Unsorted List'
Top = 16
Width = 163
Font.Color = clBlack
Font.Height = -11
Font.Name = 'Courier New'
ItemHeight = 0
ParentFont = False
TabOrder = 4
TabStop = False
end
object LB2: TListBox
Left = 180
Height = 247
Hint = 'Sorted List'
Top = 16
Width = 157
Font.Color = clBlack
Font.Height = -11
Font.Name = 'Courier New'
ItemHeight = 0
ParentFont = False
TabOrder = 5
TabStop = False
end
object NewBtn: TButton
Left = 348
Height = 35
Hint = 'Create New List'
Top = 72
Width = 71
Caption = 'New List'
OnClick = NewBtnClick
TabOrder = 1
end
object SorterBtn: TButton
Left = 348
Height = 35
Hint = 'Sort List'
Top = 133
Width = 71
Caption = 'Sort'
OnClick = SorterBtnClick
TabOrder = 2
end
object Btn4: TButton
Left = 348
Height = 35
Hint = 'Exit program'
Top = 212
Width = 71
Caption = 'Exit'
OnClick = Btn4Click
TabOrder = 3
end
object Edit1: TEdit
Left = 348
Height = 23
Hint = '# items in list'
Top = 46
Width = 69
TabOrder = 0
end
end

163
components/systools/examples/windows-only/sort/exsortu.pas Normal file
View File

@ -0,0 +1,163 @@
(* ***** 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 ExSortU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
StConst, StBase, StSort;
type
SortException = class(Exception);
TSTDlg = class(TForm)
LB1: TListBox;
LB2: TListBox;
NewBtn: TButton;
SorterBtn: TButton;
Btn4: TButton;
Edit1: TEdit;
Label1: TLabel;
procedure FormActivate(Sender: TObject);
procedure Btn4Click(Sender: TObject);
procedure SorterBtnClick(Sender: TObject);
procedure NewBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
DidGet : Boolean;
MaxElems : Integer;
ISort : TStSorter;
procedure DoRandomStrings;
end;
var
STDlg: TSTDlg;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
type
S15 = string[15];
function MyCompare(const E1, E2) : Integer; far;
begin
Result := CompareText(S15(E1),S15(E2));
end;
procedure TSTDlg.FormActivate(Sender: TObject);
var
OHTU : LongInt;
begin
MaxElems := 1000;
Edit1.Text := IntToStr(MaxElems);
DoRandomStrings;
OHTU := OptimumHeapToUse(SizeOf(S15),MaxElems);
ISort := TStSorter.Create(OHTU,SizeOf(S15));
ISort.Compare := MyCompare;
DidGet := False;
end;
procedure TSTDlg.Btn4Click(Sender: TObject);
begin
ISort.Free;
Close;
end;
procedure TSTDlg.DoRandomStrings;
var
step, I : Integer;
AStr : S15;
begin
LB1.Clear;
LB1.Perform(WM_SETREDRAW,0,0);
Randomize;
for step := 1 to MaxElems do
begin
AStr[0] := chr(15);
for I := 1 to 15 do
AStr[I] := Chr(Random(26) + Ord('A'));
LB1.Items.Add(AStr);
end;
LB1.Perform(WM_SETREDRAW,1,0);
LB1.Update;
end;
procedure TSTDlg.SorterBtnClick(Sender: TObject);
var
I : integer;
S : S15;
begin
if DidGet then
ISort.Reset;
Screen.Cursor := crHourGlass;
if LB1.Items.Count > 0 then
begin
for I := 0 to LB1.Items.Count-1 do
begin
S := LB1.Items[I];
ISort.Put(S);
end;
end;
LB2.Clear;
LB2.Perform(WM_SETREDRAW,0,0);
while (ISort.Get(S)) do
LB2.Items.Add(S);
LB2.Perform(WM_SETREDRAW,1,0);
LB2.Update;
DidGet := True;
Screen.Cursor := crDefault;
end;
procedure TSTDlg.NewBtnClick(Sender: TObject);
var
Code : Integer;
begin
Val(Edit1.Text,MaxElems,Code);
if (Code <> 0) OR (MaxElems = 0) OR (MaxElems > 5000) then
begin
ShowMessage('Invalid entry or value out of range (1..5000)');
Exit;
end;
LB2.Clear;
DoRandomStrings;
end;
end.

85
components/systools/examples/windows-only/spawn/exspawn.lpi Normal file
View File

@ -0,0 +1,85 @@
<?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="exspawn"/>
<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_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="exspawn.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="EXSPAWN"/>
</Unit0>
<Unit1>
<Filename Value="exspawnu.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="exspawn"/>
</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/windows-only/spawn/exspawn.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 EXSPAWN;
uses
Interfaces,
Forms, lclversion,
exspawnu in 'exspawnu.pas' {Form1};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

103
components/systools/examples/windows-only/spawn/exspawnu.lfm Normal file
View File

@ -0,0 +1,103 @@
object Form1: TForm1
Left = 383
Height = 188
Top = 219
Width = 212
BorderStyle = bsDialog
Caption = 'EXSPAWN'
ClientHeight = 188
ClientWidth = 212
Color = clBtnFace
Font.Color = clWindowText
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object btnSpawn: TButton
AnchorSideLeft.Control = Owner
AnchorSideLeft.Side = asrCenter
Left = 69
Height = 25
Top = 148
Width = 75
Caption = 'Spawn'
OnClick = btnSpawnClick
TabOrder = 0
end
object RG1: TRadioGroup
Left = 20
Height = 54
Top = 5
Width = 172
AutoFill = True
Caption = ' Spawn Action '
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 34
ClientWidth = 168
Columns = 2
ItemIndex = 0
Items.Strings = (
'Open'
'Print'
)
TabOrder = 1
end
object cbNotify: TCheckBox
Left = 22
Height = 19
Top = 120
Width = 53
Caption = 'Notify'
TabOrder = 2
end
object cbTimeout: TCheckBox
Left = 96
Height = 19
Top = 120
Width = 93
Caption = 'Timeout (15s)'
TabOrder = 3
end
object RG2: TRadioGroup
Left = 18
Height = 44
Top = 64
Width = 174
AutoFill = True
Caption = ' Window State '
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 2
ClientHeight = 24
ClientWidth = 170
Columns = 2
ItemIndex = 0
Items.Strings = (
'Minimized'
'Normal'
)
TabOrder = 4
end
object StSpawnApplication1: TStSpawnApplication
OnCompleted = StSpawnApplication1Completed
OnSpawnError = StSpawnApplication1SpawnError
OnTimeOut = StSpawnApplication1TimeOut
TimeOut = 15
left = 32
top = 136
end
object OpenDialog1: TOpenDialog
DefaultExt = '.TXT'
Filter = 'Text files (*.txt)|*.txt|All files (*.*)|*.*'
left = 152
top = 136
end
end

114
components/systools/examples/windows-only/spawn/exspawnu.pas Normal file
View File

@ -0,0 +1,114 @@
(* ***** 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 exspawnu;
interface
uses
Windows, SysUtils, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ShellAPI, ExtCtrls,
StBase, StSpawn;
type
TForm1 = class(TForm)
StSpawnApplication1: TStSpawnApplication;
btnSpawn: TButton;
RG1: TRadioGroup;
OpenDialog1: TOpenDialog;
cbNotify: TCheckBox;
cbTimeout: TCheckBox;
RG2: TRadioGroup;
procedure btnSpawnClick(Sender: TObject);
procedure StSpawnApplication1Completed(Sender: TObject);
procedure StSpawnApplication1SpawnError(Sender: TObject; Error: Word);
procedure StSpawnApplication1TimeOut(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure EnableControls(B : Boolean);
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.EnableControls(B : Boolean);
begin
rg1.Enabled := B;
rg2.Enabled := B;
cbNotify.Enabled := B;
cbTimeOut.Enabled := B;
btnSpawn.Enabled := B;
end;
procedure TForm1.btnSpawnClick(Sender: TObject);
begin
if OpenDialog1.Execute then begin
StSpawnApplication1.FileName := OpenDialog1.FileName;
StSpawnApplication1.SpawnCommand := TStSpawnCommand(rg1.ItemIndex);
StSpawnApplication1.NotifyWhenDone := cbNotify.Checked;
if (rg2.ItemIndex = 0) then
StSpawnApplication1.ShowState := ssMinimized
else
StSpawnApplication1.ShowState := ssNormal;
StSpawnApplication1.TimeOut := Ord(cbTimeout.Checked) * 15;
EnableControls(StSpawnApplication1.TimeOut = 0);
StSpawnApplication1.Execute;
end;
end;
procedure TForm1.StSpawnApplication1Completed(Sender: TObject);
begin
EnableControls(True);
ShowMessage('Done');
end;
procedure TForm1.StSpawnApplication1SpawnError(Sender: TObject; Error: Word);
begin
EnableControls(True);
ShowMessage(IntToStr(Error));
end;
procedure TForm1.StSpawnApplication1TimeOut(Sender: TObject);
begin
EnableControls(True);
ShowMessage('TimeOut');
end;
end.

86
components/systools/examples/windows-only/text_sort/textsort.lpi Normal file
View File

@ -0,0 +1,86 @@
<?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="textsort"/>
<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_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="textsort.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Textsort"/>
</Unit0>
<Unit1>
<Filename Value="txtsortu.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="STDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="TxtSortU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="textsort"/>
</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/windows-only/text_sort/textsort.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 Textsort;
uses
Interfaces,
Forms, lclversion,
TxtSortU in 'TxtSortU.pas' {STDlg};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

199
components/systools/examples/windows-only/text_sort/txtsortu.lfm Normal file
View File

@ -0,0 +1,199 @@
object STDlg: TSTDlg
Left = 354
Height = 274
Top = 324
Width = 329
ActiveControl = InFile
BorderStyle = bsDialog
Caption = 'TextSort'
ClientHeight = 274
ClientWidth = 329
Color = clBtnFace
Font.Color = clBlack
OnActivate = FormActivate
OnClose = FormClose
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object GroupBox1: TGroupBox
Left = 6
Height = 87
Top = 12
Width = 231
Caption = 'File Names'
ClientHeight = 67
ClientWidth = 227
TabOrder = 0
object Label1: TLabel
Left = 8
Height = 15
Top = 11
Width = 28
Caption = 'Input'
ParentColor = False
end
object Label2: TLabel
Left = 8
Height = 15
Top = 39
Width = 38
Caption = 'Output'
ParentColor = False
end
object InputBtn: TSpeedButton
Left = 200
Height = 21
Top = 9
Width = 25
Caption = '...'
OnClick = InputBtnClick
end
object OutputBtn: TSpeedButton
Left = 200
Height = 21
Top = 37
Width = 25
Caption = '...'
OnClick = OutputBtnClick
end
object InFile: TEdit
Left = 60
Height = 23
Top = 8
Width = 135
TabOrder = 0
end
object OutFile: TEdit
Left = 60
Height = 23
Top = 36
Width = 135
TabOrder = 1
end
end
object GroupBox2: TGroupBox
Left = 6
Height = 82
Top = 110
Width = 107
Caption = 'Sort Options'
ClientHeight = 62
ClientWidth = 103
TabOrder = 1
object RevOrder: TCheckBox
Left = 12
Height = 19
Top = 4
Width = 93
Caption = 'Reverse Order'
TabOrder = 0
end
object IgnoreCase: TCheckBox
Left = 12
Height = 19
Top = 30
Width = 82
Caption = 'Ignore Case'
TabOrder = 1
end
end
object GroupBox3: TGroupBox
Left = 120
Height = 82
Top = 110
Width = 119
Caption = 'Sort Key'
ClientHeight = 62
ClientWidth = 115
TabOrder = 2
object Label3: TLabel
Left = 8
Height = 15
Top = 7
Width = 24
Caption = 'Start'
ParentColor = False
end
object Label4: TLabel
Left = 8
Height = 15
Top = 33
Width = 37
Caption = 'Length'
ParentColor = False
end
object StartPos: TEdit
Left = 64
Height = 23
Top = 4
Width = 41
TabOrder = 0
end
object KeyLen: TEdit
Left = 64
Height = 23
Top = 30
Width = 41
TabOrder = 1
end
end
object OkBtn: TBitBtn
Left = 252
Height = 33
Top = 18
Width = 67
Caption = '&OK'
NumGlyphs = 2
OnClick = OkBtnClick
TabOrder = 4
end
object CloseBtn: TBitBtn
Left = 252
Height = 33
Top = 231
Width = 67
Caption = '&Close'
NumGlyphs = 2
OnClick = CloseBtnClick
TabOrder = 6
end
object GroupBox4: TGroupBox
Left = 6
Height = 56
Top = 208
Width = 233
Caption = 'Sort Status'
ClientHeight = 36
ClientWidth = 229
TabOrder = 3
object Status: TLabel
Left = 16
Height = 15
Top = 8
Width = 19
Caption = 'Idle'
ParentColor = False
end
end
object AbortBtn: TBitBtn
Left = 252
Height = 33
Top = 66
Width = 67
Caption = '&Abort'
NumGlyphs = 2
OnClick = AbortBtnClick
TabOrder = 5
end
object OpenDialog1: TOpenDialog
DefaultExt = '.TXT'
Filter = 'Text files (*.txt)|*.txt|All files (*.*)|*.*'
left = 264
top = 120
end
object SaveDialog1: TSaveDialog
DefaultExt = '.TXT'
Filter = 'Text files (*.txt)|*.txt|All files (*.txt)|*.*'
left = 264
top = 176
end
end

324
components/systools/examples/windows-only/text_sort/txtsortu.pas Normal file
View File

@ -0,0 +1,324 @@
(* ***** 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 TxtSortU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons,
StConst, StBase, StColl, StSort;
const
MaxStrLen = 1024;
type
SortException = class(Exception);
LineBuf = array[0..MaxStrLen-1] of char;
TSTDlg = class(TForm)
GroupBox1: TGroupBox;
Label1: TLabel;
Label2: TLabel;
InFile: TEdit;
OutFile: TEdit;
GroupBox2: TGroupBox;
RevOrder: TCheckBox;
IgnoreCase: TCheckBox;
GroupBox3: TGroupBox;
Label3: TLabel;
Label4: TLabel;
StartPos: TEdit;
KeyLen: TEdit;
OkBtn: TBitBtn;
CloseBtn: TBitBtn;
GroupBox4: TGroupBox;
Status: TLabel;
AbortBtn: TBitBtn;
OpenDialog1: TOpenDialog;
SaveDialog1: TSaveDialog;
InputBtn: TSpeedButton;
OutputBtn: TSpeedButton;
procedure OkBtnClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure CloseBtnClick(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure AbortBtnClick(Sender: TObject);
procedure InputBtnClick(Sender: TObject);
procedure OutputBtnClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
DoAbort,
InSort,
DoRev,
Ignore : Boolean;
SPos,
KeyL : Integer;
LC : LongInt;
InF,
OutF : TextFile;
MySort : TStSorter;
function ValidateEntryFields : Boolean;
procedure CleanUp;
end;
var
STDlg: TSTDlg;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure DelNodeData(Data : pointer); far;
{-procedure to delete data pointer in each node}
begin
Dispose(Data);
end;
function TFSorter(const S1, S2) : Integer; far;
var
PX, PY : LineBuf;
begin
if STDlg.DoRev then begin
StrCopy(PX, LineBuf(S2));
StrCopy(PY, LineBuf(S1));
end else begin
StrCopy(PX, LineBuf(S1));
StrCopy(PY, LineBuf(S2));
end;
if STDlg.Ignore then begin
if (StrLIComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
Result := -1
else
Result := 0;
end else begin
if (StrLComp(@PX[STDlg.SPos-1], @PY[STDlg.SPos-1], STDlg.KeyL) < 0) then
Result := -1
else
Result := 0;
end;
end;
procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if MySort <> nil then
MySort.Free;
end;
procedure TSTDlg.CloseBtnClick(Sender: TObject);
begin
if InSort then Exit;
Close;
end;
function TSTDlg.ValidateEntryFields : Boolean;
var
Code : Integer;
begin
Result := False;
if NOT FileExists(InFile.Text) then
begin
ShowMessage('Input file does not exist');
Exit;
end;
if FileExists(OutFile.Text) then
begin
if MessageDlg('Output file exists' + #13 + 'Continue?',
mtConfirmation,[mbYes,mbNo],0) = mrNo then
Exit;
end;
if (CompareText(InFile.Text,OutFile.Text) = 0) then
begin
ShowMessage('Input and Output file can not be the same');
Exit;
end;
val(StartPos.Text,SPos,Code);
if (Code <> 0) then
begin
ShowMessage('Invalid Start entry');
Exit;
end;
if (SPos < 1) OR (SPos >= MaxStrLen) then
begin
ShowMessage('Start out of range');
Exit;
end;
val(KeyLen.Text,KeyL,Code);
if (Code <> 0) then
begin
ShowMessage('Invalid Length entry');
Exit;
end;
if (KeyL < 1) OR (KeyL > MaxStrLen-SPos) then
begin
ShowMessage('Key Length out of range');
Exit;
end;
DoRev := RevOrder.Checked;
Ignore := IgnoreCase.Checked;
Result := True;
end;
procedure TSTDlg.CleanUp;
begin
CloseFile(InF);
CloseFile(OutF);
InSort := False;
DoAbort := True;
MySort.Free;
MySort := nil;
end;
procedure TSTDlg.OkBtnClick(Sender: TObject);
var
PS : LineBuf;
begin
if NOT ValidateEntryFields then
Exit;
AssignFile(InF,InFile.Text);
Reset(InF);
AssignFile(OutF,OutFile.Text);
ReWrite(OutF);
if MySort <> nil then begin
MySort.Free;
MySort := nil;
end;
MySort := TStSorter.Create(500000, SizeOf(LineBuf));
MySort.Compare := TFSorter;
DoAbort := False;
InSort := True;
LC := 0;
while NOT EOF(InF) do begin
FillChar(PS, SizeOf(PS), #0);
Readln(InF, PS);
Inc(LC);
Status.Caption := 'Reading/Sorting line: ' + IntToStr(LC);
MySort.Put(PS);
if (LC mod 100) = 0 then begin
Application.ProcessMessages;
if DoAbort then begin
CleanUp;
Status.Caption := 'Sort Aborted';
Exit;
end;
end;
end;
Status.Caption := 'Processing';
Status.Update;
Application.ProcessMessages;
if NOT DoAbort then begin
LC := 0;
while MySort.Get(PS) do begin
Inc(LC);
Status.Caption := 'Writing line: ' + IntToStr(LC);
Writeln(OutF, PS);
if (LC mod 100) = 0 then begin
Application.ProcessMessages;
if DoAbort then begin
CleanUp;
Status.Caption := 'Sort Aborted';
Exit;
end;
end;
end;
end;
if NOT DoAbort then begin
CleanUp;
Status.Caption := 'Done';
end;
end;
procedure TSTDlg.FormActivate(Sender: TObject);
begin
IgnoreCase.Checked := True;
RevOrder.Checked := False;
InFile.Text := '';
OutFile.Text := '';
StartPos.Text := '1';
KeyLen.Text := '20';
Status.Caption := 'Idle';
end;
procedure TSTDlg.AbortBtnClick(Sender: TObject);
begin
DoAbort := True;
end;
procedure TSTDlg.InputBtnClick(Sender: TObject);
begin
if OpenDialog1.Execute then
InFile.Text := OpenDialog1.FileName;
end;
procedure TSTDlg.OutputBtnClick(Sender: TObject);
begin
if SaveDialog1.Execute then
OutFile.Text := SaveDialog1.FileName;
end;
end.

41
components/systools/examples/windows-only/version_info/exvinfou.lfm Normal file
View File

@ -0,0 +1,41 @@
object Form1: TForm1
Left = 197
Height = 262
Top = 108
Width = 494
Caption = 'Version Info Example'
ClientHeight = 262
ClientWidth = 494
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object Button1: TButton
Left = 16
Height = 25
Top = 24
Width = 75
Caption = 'Open...'
OnClick = Button1Click
TabOrder = 0
end
object Memo1: TMemo
Left = 120
Height = 233
Top = 24
Width = 369
Lines.Strings = (
'Use the "open" button to select a file that contains version '
'information.'
)
TabOrder = 1
end
object OpenDialog1: TOpenDialog
left = 32
top = 64
end
object VerInfo: TStVersionInfo
left = 32
top = 136
end
end

105
components/systools/examples/windows-only/version_info/exvinfou.pas Normal file
View File

@ -0,0 +1,105 @@
(* ***** 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 ExVInfoU;
interface
uses
Windows, Messages,
SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,
StVInfo, StBase;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
OpenDialog1: TOpenDialog;
VerInfo: TStVersionInfo;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
procedure ShowVersionInfo;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$IFDEF FPC}
{$R *.lfm}
{$ELSE}
{$R *.dfm}
{$ENDIF}
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then begin
VerInfo.FileName := OpenDialog1.FileName;
ShowVersionInfo;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowVersionInfo;
end;
procedure TForm1.ShowVersionInfo;
begin
with Memo1.Lines do begin
Memo1.Clear;
Add('Comments: ' + VerInfo.Comments);
Add('Company Name: ' + VerInfo.CompanyName);
Add('File Description: ' + VerInfo.FileDescription);
Add('File Version: ' + VerInfo.FileVersion);
Add('Internal Name: ' + VerInfo.InternalName);
Add('Legal Copyright: ' + VerInfo.LegalCopyright);
Add('Legal Trademark: ' + VerInfo.LegalTrademark);
Add('Original Filename: ' + VerInfo.OriginalFilename);
Add('Product Name: ' + VerInfo.ProductName);
Add('Product Version: ' + VerInfo.ProductVersion);
{$IFNDEF FPC}
if UpperCase(ExtractFileName(VerInfo.FileName))
= UpperCase('exvrinfo.exe') then begin
Add('Extra Info 1: ' + VerInfo.GetKeyValue('ExtraInfo1'));
Add('Extra Info 2: ' + VerInfo.GetKeyValue('ExtraInfo2'));
end;
{$ENDIF}
Add('Language: ' + VerInfo.LanguageName);
if VerInfo.FileDate <> 0 then
Add('File Date: ' + DateToStr(VerInfo.FileDate));
end;
end;
end.

91
components/systools/examples/windows-only/version_info/exvrinfo.lpi Normal file
View File

@ -0,0 +1,91 @@
<?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="exvrinfo"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<VersionInfo>
<UseVersionInfo Value="True"/>
<AutoIncrementBuild Value="True"/>
<MajorVersionNr Value="1"/>
<StringTable Comments="This is a comment" CompanyName="Turbo Power &amp; Lazarus" FileDescription="File version info viewer" InternalName="ExVrInfo" OriginalFilename="ExVrInfo.exe"/>
</VersionInfo>
<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_systoolswin"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="exvrinfo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="exvinfou.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExVInfoU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exvrinfo"/>
</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/windows-only/version_info/exvrinfo.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 exvrinfo;
uses
Interfaces,
Forms, lclversion,
ExVInfoU in 'ExVInfoU.pas' {Form1};
{$R *.res}
begin
{$IF LCL_FULLVERSION >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.