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

systools: Initial commit of Lazarus port of TurboPower SysTools (incomplete).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6140 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-01-16 23:57:15 +00:00
parent 8a83458360
commit 93e37e8e76
69 changed files with 50434 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

86
components/systools/examples/barcode (postnet)/expnbar.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="expnbar"/>
<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="3">
<Item1>
<PackageName Value="Printer4Lazarus"/>
</Item1>
<Item2>
<PackageName Value="laz_systools"/>
</Item2>
<Item3>
<PackageName Value="LCL"/>
</Item3>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="expnbar.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="expnbaru.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="frmPostNet"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="expnbar"/>
</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>

39
components/systools/examples/barcode (postnet)/expnbar.lpr Normal file
View File

@ -0,0 +1,39 @@
(* ***** 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 ***** *)
program expnbar;
uses
Interfaces,
Forms, printer4lazarus,
expnbaru in 'expnbaru.pas' {frmPostNet};
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TfrmPostNet, frmPostNet);
Application.Run;
end.

96
components/systools/examples/barcode (postnet)/expnbaru.lfm Normal file
View File

@ -0,0 +1,96 @@
object frmPostNet: TfrmPostNet
Left = 291
Height = 191
Top = 145
Width = 231
BorderStyle = bsDialog
Caption = 'PostNet Barcode Example'
ClientHeight = 191
ClientWidth = 231
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 14
Height = 15
Top = 80
Width = 51
Caption = 'From Left'
ParentColor = False
end
object Label2: TLabel
Left = 128
Height = 15
Top = 80
Width = 51
Caption = 'From Top'
ParentColor = False
end
object BarCode1: TStPNBarCode
Left = 16
Height = 16
Top = 15
Width = 199
PostalCode = '12345'
end
object Label3: TLabel
Left = 76
Height = 15
Top = 44
Width = 17
Caption = 'ZIP'
ParentColor = False
end
object btnPrint: TButton
Left = 80
Height = 25
Top = 144
Width = 75
Caption = 'Print'
OnClick = btnPrintClick
TabOrder = 1
end
object meZIP: TMaskEdit
Left = 103
Height = 22
Top = 40
Width = 52
CharCase = ecNormal
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Courier New'
MaxLength = 5
ParentFont = False
TabOrder = 0
OnChange = meZIPChange
EditMask = '00000;1;_'
Text = '12345'
SpaceChar = '_'
end
object edLeft: TFloatSpinEdit
Left = 15
Height = 23
Top = 98
Width = 74
Alignment = taRightJustify
Increment = 0.1
MaxValue = 10
MinValue = 0
TabOrder = 2
Value = 2.5
end
object edTop: TFloatSpinEdit
Left = 128
Height = 23
Top = 98
Width = 74
Alignment = taRightJustify
Increment = 0.1
MaxValue = 10
MinValue = 0
TabOrder = 3
Value = 2.5
end
end

116
components/systools/examples/barcode (postnet)/expnbaru.pas Normal file
View File

@ -0,0 +1,116 @@
(* ***** 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 ***** *)
(******************************************************************************
Enter a five-digit zip code and the inches to print from the left and top of
the page or envelope. Don't forget that laser printers can't print all the
way to the edge and so the value you enter must be adjusted accordingly. For
example, if you enter 5.0 for the "From Left" value and the printer has a
1/4" non-printable border, the bar code will be located 5.25" from the
actual edge of the paper.
NOTE: Be sure to change the constant PrinterPixPerInch to match the
resolution of your printer.
*******************************************************************************)
unit expnbaru;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, MaskEdit, Spin,
StBarPN;
const
PrinterPixPerInch = 600;
type
{ TfrmPostNet }
TfrmPostNet = class(TForm)
btnPrint: TButton;
edLeft: TFloatSpinEdit;
Label1: TLabel;
Label2: TLabel;
edTop: TFloatSpinEdit;
BarCode1: TStPNBarCode;
meZIP: TMaskEdit;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
procedure btnPrintClick(Sender: TObject);
procedure meZIPChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmPostNet: TfrmPostNet;
implementation
{$R *.lfm}
uses
Printers,
StStrS;
procedure TfrmPostNet.FormCreate(Sender: TObject);
begin
meZIP.Text := BarCode1.PostalCode;
//edLeft.Text := ' 5' + DecimalSeparator + '0';
//edTop.Text := ' 3' + DecimalSeparator + '9';
end;
procedure TfrmPostNet.btnPrintClick(Sender: TObject);
var
P : TPoint;
L,
T : longint;
begin
L := Round(edLeft.Value * PrinterPixPerInch);
T := Round(edTop.Value * PrinterPixPerInch);
P := Point(L, T);
Printer.BeginDoc;
BarCode1.PaintToPrinterCanvas(Printer.Canvas, P);
Printer.EndDoc;
end;
procedure TfrmPostNet.meZIPChange(Sender: TObject);
var
S : ShortString;
begin
S := TrimS(meZIP.Text);
if (Length(S) = 5) then
BarCode1.PostalCode := meZIP.Text;
end;
end.

840
components/systools/examples/barcode/ExBarCU.lfm Normal file
View File

@ -0,0 +1,840 @@
object BarCodeForm: TBarCodeForm
Left = 214
Height = 580
Top = 137
Width = 612
Caption = 'Bar Code Component Example'
ClientHeight = 580
ClientWidth = 612
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '1.9.0.0'
Scaled = False
object StDbBarCode1: TStDbBarCode
Left = 3
Height = 65
Top = 320
Width = 606
Anchors = [akTop, akLeft, akRight]
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcCode93
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = False
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
DataField = 'Company'
DataSource = DataSource1
end
object Label4: TLabel
Left = 3
Height = 15
Top = 301
Width = 240
Caption = 'Code 93 bar code attached to a database field'
ParentColor = False
end
object NB: TPageControl
Left = 3
Height = 273
Top = 3
Width = 606
ActivePage = TabSheet1
Align = alTop
BorderSpacing.Around = 3
TabIndex = 0
TabOrder = 4
OnChange = NBChange
object TabSheet1: TTabSheet
Caption = 'UPC/EAN'
ClientHeight = 245
ClientWidth = 598
object BarCode1: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcUPC_A
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = False
Code = '12345678902'
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = True
end
object Label1: TLabel
Left = 8
Height = 15
Top = 8
Width = 127
Caption = 'Code: 11 or 12 Numeric '
ParentColor = False
end
object edCode1: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
MaxLength = 12
OnExit = btnUpdate1Click
TabOrder = 0
Text = '012345678820'
end
object edSupp: TEdit
Left = 160
Height = 23
Top = 26
Width = 49
Enabled = False
MaxLength = 5
OnExit = btnUpdate1Click
TabOrder = 2
Text = '12345'
end
object rgType: TRadioGroup
Left = 336
Height = 105
Top = 25
Width = 81
AutoFill = True
Caption = 'Type'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 85
ClientWidth = 77
ItemIndex = 0
Items.Strings = (
'UPC_A'
'UPC_E'
'EAN_13'
'EAN_8'
)
OnClick = btnUpdate1Click
TabOrder = 4
end
object cbSupp: TCheckBox
Left = 160
Height = 19
Top = 7
Width = 244
Caption = 'Encode supplemental data: 2 or 5 Numeric'
OnClick = btnUpdate1Click
TabOrder = 1
end
object cbTallGuardBars: TCheckBox
Left = 8
Height = 19
Top = 168
Width = 98
Caption = 'Tall guard bars'
Checked = True
OnClick = btnUpdate1Click
State = cbChecked
TabOrder = 6
end
object cbShowCode: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate1Click
State = cbChecked
TabOrder = 5
end
object btnUpdate1: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate1Click
TabOrder = 3
end
end
object TabSheet2: TTabSheet
Caption = 'Interleaved 2 of 5'
ClientHeight = 245
ClientWidth = 575
object BarCode2: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcInterleaved2of5
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = True
Code = '0123456789'
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
end
object Label2: TLabel
Left = 8
Height = 15
Top = 8
Width = 83
Caption = 'Code: Numeric '
ParentColor = False
end
object cbBearerBars: TCheckBox
Left = 8
Height = 19
Top = 168
Width = 78
Caption = 'Bearer Bars'
Checked = True
OnClick = btnUpdate2Click
State = cbChecked
TabOrder = 3
end
object cbShowCode2: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate2Click
State = cbChecked
TabOrder = 2
end
object edCode2: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdate2Click
TabOrder = 0
Text = '0123456789'
end
object btnUpdate2: TButton
Left = 224
Height = 25
Top = 24
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate2Click
TabOrder = 1
end
end
object TabSheet3: TTabSheet
Caption = 'Codabar'
ClientHeight = 245
ClientWidth = 575
object Label3: TLabel
Left = 8
Height = 15
Top = 8
Width = 136
Caption = 'Code: Numeric and -$:/.+'
ParentColor = False
end
object BarCode3: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcCodabar
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = True
Code = 'c123456d'
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
end
object edCode3: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdate3Click
TabOrder = 0
Text = 'c123456d'
end
object Button2: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate3Click
TabOrder = 1
end
object cbShowCode3: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate3Click
State = cbChecked
TabOrder = 2
end
object cbShowGuardChars3: TCheckBox
Left = 8
Height = 19
Top = 168
Width = 140
Caption = 'Show guard characters'
OnClick = btnUpdate3Click
TabOrder = 3
end
end
object TabSheet4: TTabSheet
Caption = 'Code 11'
ClientHeight = 245
ClientWidth = 575
object BarCode4: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcCode11
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = True
Code = '1234567890'
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
end
object Label5: TLabel
Left = 8
Height = 15
Top = 8
Width = 111
Caption = 'Code: Numeric and -'
ParentColor = False
end
object cbShowCode4: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate4Click
OnExit = btnUpdate4Click
State = cbChecked
TabOrder = 2
end
object Button1: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate4Click
TabOrder = 1
end
object edCode4: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdate4Click
TabOrder = 0
Text = '1234567890'
end
end
object TabSheet5: TTabSheet
Caption = 'Code 39'
ClientHeight = 245
ClientWidth = 575
object BarCode5: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcCode39
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = False
Code = '123456789'
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
end
object Label6: TLabel
Left = 8
Height = 15
Top = 8
Width = 187
Caption = 'Code: Alpha-Numeric and -. $/+%*'
ParentColor = False
end
object edCode5: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdate5Click
TabOrder = 0
Text = '123456789'
end
object btnUpdate5: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate5Click
TabOrder = 1
end
object cbShowCode5: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate5Click
State = cbChecked
TabOrder = 2
end
end
object TabSheet6: TTabSheet
Caption = 'Code 93'
ClientHeight = 245
ClientWidth = 575
object BarCode6: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcCode93
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = False
Code = 'CODE 93'
Code128Subset = csCodeA
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
end
object Label7: TLabel
Left = 8
Height = 15
Top = 8
Width = 187
Caption = 'Code: Alpha-Numeric and -. $/+%*'
ParentColor = False
end
object edCode6: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdate6Click
TabOrder = 0
Text = 'CODE 93'
end
object btnUpdate6: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate6Click
TabOrder = 1
end
object cbShowCode6: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate6Click
State = cbChecked
TabOrder = 2
end
end
object TabSheet7: TTabSheet
Caption = 'Code 128'
ClientHeight = 245
ClientWidth = 575
object BarCode7: TStBarCode
Left = 8
Height = 80
Top = 56
Width = 321
Color = clWhite
ParentColor = False
AddCheckChar = True
BarCodeType = bcCode128
BarColor = clBlack
BarToSpaceRatio = 1
BarWidth = 12
BearerBars = False
Code = '123456789ABCD'
Code128Subset = csCodeB
ShowCode = True
ShowGuardChars = False
TallGuardBars = False
end
object Label8: TLabel
Left = 8
Height = 15
Top = 8
Width = 134
Caption = 'Code: Fill Alpha-Numeric'
ParentColor = False
end
object edCode7: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdate7Click
TabOrder = 0
Text = '123456789ABCD'
end
object btnUpdate7: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdate7Click
TabOrder = 1
end
object cbShowCode7: TCheckBox
Left = 8
Height = 19
Top = 144
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdate7Click
State = cbChecked
TabOrder = 2
end
end
object TabSheet8: TTabSheet
Caption = 'PDF417'
ClientHeight = 245
ClientWidth = 575
object Label9: TLabel
Left = 8
Height = 15
Top = 8
Width = 134
Caption = 'Code: Fill Alpha-Numeric'
ParentColor = False
end
object StPDF417Barcode1: TStPDF417Barcode
Left = 8
Height = 121
Top = 56
Width = 457
ParentColor = False
Alignment = taLeftJustify
BarWidth = 1
Code = '123456789'
Caption = '123456789'
end
object edCodePDF417: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdatePDF417Click
TabOrder = 0
Text = '123456789'
end
object btnUpdatePDF417: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdatePDF417Click
TabOrder = 1
end
object cbShowCodePDF417: TCheckBox
Left = 8
Height = 19
Top = 184
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdatePDF417Click
State = cbChecked
TabOrder = 2
end
object cbPDF417Truncated: TCheckBox
Left = 128
Height = 19
Top = 184
Width = 74
Caption = 'Truncated'
OnClick = btnUpdatePDF417Click
TabOrder = 3
end
end
object TabSheet9: TTabSheet
Caption = 'MaxiCode'
ClientHeight = 245
ClientWidth = 598
object Label10: TLabel
Left = 8
Height = 15
Top = 8
Width = 134
Caption = 'Code: Fill Alpha-Numeric'
ParentColor = False
end
object Label11: TLabel
Left = 224
Height = 15
Top = 56
Width = 87
Caption = 'MaxiCode Mode'
ParentColor = False
end
object Label12: TLabel
Left = 224
Height = 15
Top = 152
Width = 63
Caption = 'Postal Code'
ParentColor = False
end
object Label13: TLabel
Left = 224
Height = 15
Top = 128
Width = 74
Caption = 'Country Code'
ParentColor = False
end
object Label14: TLabel
Left = 224
Height = 15
Top = 176
Width = 67
Caption = 'Service Class'
ParentColor = False
end
object StMaxiCodeBarcode1: TStMaxiCodeBarcode
Left = 8
Top = 50
ParentColor = False
CarrierPostalCode = '000000000'
HorPixelsPerMM = 4
VerPixelsPerMM = 4
Code = '123456789'
Caption = '123456789'
end
object edCodeMaxiCode: TEdit
Left = 8
Height = 23
Top = 26
Width = 137
OnExit = btnUpdateMaxiCodeClick
TabOrder = 0
Text = '123456789'
end
object btnUpdateMaxiCode: TButton
Left = 224
Height = 25
Top = 25
Width = 105
Caption = 'Update Symbol'
OnClick = btnUpdateMaxiCodeClick
TabOrder = 1
end
object cbShowCodeMaxiCode: TCheckBox
Left = 8
Height = 19
Top = 184
Width = 78
Caption = 'Show code'
Checked = True
OnClick = btnUpdateMaxiCodeClick
State = cbChecked
TabOrder = 8
end
object radMCMode23: TRadioButton
Left = 232
Height = 19
Top = 72
Width = 121
Caption = 'Carrier Information'
OnClick = radMCMode23Click
TabOrder = 2
end
object radMCMode4: TRadioButton
Left = 232
Height = 19
Top = 88
Width = 110
Caption = 'Standard Symbol'
Checked = True
OnClick = radMCMode4Click
TabOrder = 3
TabStop = True
end
object radMCMode5: TRadioButton
Left = 232
Height = 19
Top = 104
Width = 62
Caption = 'Full EEC'
OnClick = radMCMode5Click
TabOrder = 4
end
object edMCCountryCode: TEdit
Left = 309
Height = 23
Top = 125
Width = 33
Enabled = False
TabOrder = 5
Text = '000'
end
object edMCPostalCode: TEdit
Left = 309
Height = 23
Top = 149
Width = 73
Enabled = False
TabOrder = 6
Text = '000000000'
end
object edMCServiceClass: TEdit
Left = 309
Height = 23
Top = 173
Width = 33
Enabled = False
TabOrder = 7
Text = '000'
end
end
end
object btnCopy: TButton
Left = 264
Height = 25
Top = 240
Width = 75
Caption = 'Copy'
OnClick = btnCopyClick
TabOrder = 3
end
object btnPrint: TButton
Left = 16
Height = 25
Top = 240
Width = 75
Caption = 'Print Test'
OnClick = btnPrintClick
TabOrder = 0
end
object btnClose: TButton
Left = 504
Height = 25
Top = 280
Width = 99
Anchors = [akTop, akLeft, akRight]
Cancel = True
Caption = 'Close'
ModalResult = 2
OnClick = btnCloseClick
TabOrder = 5
end
object DBGrid1: TDBGrid
Left = 3
Height = 186
Top = 392
Width = 606
Anchors = [akTop, akLeft, akRight, akBottom]
Color = clWindow
Columns = <>
DataSource = DataSource1
TabOrder = 6
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
end
object btnSave: TButton
Left = 181
Height = 25
Top = 240
Width = 75
Caption = 'Save'
OnClick = btnSaveClick
TabOrder = 2
end
object btnValidate: TButton
Left = 98
Height = 25
Top = 240
Width = 75
Caption = 'Validate'
OnClick = btnValidateClick
TabOrder = 1
end
object PrintDialog1: TPrintDialog
left = 448
top = 208
end
object BufDataset1: TBufDataset
FieldDefs = <>
left = 192
top = 432
end
object DataSource1: TDataSource
DataSet = BufDataset1
left = 320
top = 432
end
end

470
components/systools/examples/barcode/ExBarCU.pas Normal file
View File

@ -0,0 +1,470 @@
(* ***** 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 ***** *)
unit ExBarCU;
interface
uses
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Printers, ExtCtrls, ComCtrls, Grids,
Db, BufDataset, DBCtrls, DBGrids, PrintersDlgs,
StBase, StBarC, StDbBarC, St2DBarC;
type
{ TBarCodeForm }
TBarCodeForm = class(TForm)
btnPrint: TButton;
BufDataset1: TBufDataset;
DataSource1: TDataSource;
PrintDialog1: TPrintDialog;
NB: TPageControl;
Tabsheet1: TTabsheet;
Tabsheet2: TTabsheet;
Tabsheet3: TTabsheet;
Tabsheet4: TTabsheet;
Tabsheet5: TTabsheet;
Tabsheet6: TTabsheet;
Tabsheet7: TTabsheet;
Tabsheet8: TTabsheet;
Tabsheet9: TTabsheet;
edCode1: TEdit;
edSupp: TEdit;
Label1: TLabel;
BarCode1: TStBarCode;
btnCopy: TButton;
BarCode2: TStBarCode;
BarCode5: TStBarCode;
rgType: TRadioGroup;
cbSupp: TCheckBox;
btnClose: TButton;
cbTallGuardBars: TCheckBox;
cbShowCode: TCheckBox;
btnUpdate1: TButton;
cbBearerBars: TCheckBox;
cbShowCode2: TCheckBox;
Label2: TLabel;
edCode2: TEdit;
btnUpdate2: TButton;
BarCode7: TStBarCode;
DBGrid1: TDBGrid;
btnSave: TButton;
BarCode6: TStBarCode;
StDbBarCode1: TStDbBarCode;
Label3: TLabel;
edCode3: TEdit;
Button2: TButton;
cbShowCode3: TCheckBox;
BarCode3: TStBarCode;
Label4: TLabel;
cbShowGuardChars3: TCheckBox;
cbShowCode4: TCheckBox;
BarCode4: TStBarCode;
Button1: TButton;
edCode4: TEdit;
Label5: TLabel;
Label6: TLabel;
edCode5: TEdit;
btnUpdate5: TButton;
cbShowCode5: TCheckBox;
Label7: TLabel;
edCode6: TEdit;
btnUpdate6: TButton;
cbShowCode6: TCheckBox;
Label8: TLabel;
edCode7: TEdit;
btnUpdate7: TButton;
cbShowCode7: TCheckBox;
Label9: TLabel;
edCodePDF417: TEdit;
btnUpdatePDF417: TButton;
cbShowCodePDF417: TCheckBox;
Label10: TLabel;
edCodeMaxiCode: TEdit;
btnUpdateMaxiCode: TButton;
cbShowCodeMaxiCode: TCheckBox;
radMCMode23: TRadioButton;
radMCMode4: TRadioButton;
radMCMode5: TRadioButton;
Label11: TLabel;
edMCCountryCode: TEdit;
edMCPostalCode: TEdit;
edMCServiceClass: TEdit;
Label12: TLabel;
Label13: TLabel;
Label14: TLabel;
cbPDF417Truncated: TCheckBox;
StPDF417Barcode1: TStPDF417Barcode;
StMaxiCodeBarcode1: TStMaxiCodeBarcode;
btnValidate: TButton;
procedure btnPrintClick(Sender: TObject);
procedure btnCopyClick(Sender: TObject);
procedure btnValidateClick(Sender: TObject);
procedure btnUpdate1Click(Sender: TObject);
procedure btnCloseClick(Sender: TObject);
procedure btnSaveClick(Sender: TObject);
procedure btnUpdate2Click(Sender: TObject);
procedure btnUpdate3Click(Sender: TObject);
procedure btnUpdate4Click(Sender: TObject);
procedure btnUpdate5Click(Sender: TObject);
procedure btnUpdate6Click(Sender: TObject);
procedure btnUpdate7Click(Sender: TObject);
procedure btnUpdatePDF417Click(Sender: TObject);
procedure btnUpdateMaxiCodeClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure radMCMode4Click(Sender: TObject);
procedure radMCMode23Click(Sender: TObject);
procedure radMCMode5Click(Sender: TObject);
procedure NBChange(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
BarCodeForm: TBarCodeForm;
implementation
{$R *.lfm}
procedure TBarCodeForm.btnPrintClick(Sender: TObject);
begin
if not PrintDialog1.Execute then
Exit;
Application.ProcessMessages;
Screen.Cursor := crHourGlass;
try
Printer.BeginDoc;
try
Printer.Title := 'StBarCode';
BarCode1.BarcodeType := bcUPC_A;
BarCode1.Code := '52100014015';
BarCode1.SupplementalCode := '';
BarCode1.PaintToCanvasSize(Printer.Canvas, 0.5, 0.5, 0.5);
BarCode1.SupplementalCode := '12';
BarCode1.PaintToCanvasSize(Printer.Canvas, 3.0, 0.5, 0.5);
BarCode1.SupplementalCode := '12345';
BarCode1.PaintToCanvasSize(Printer.Canvas, 6.0, 0.5, 0.5);
BarCode1.BarcodeType :=bcUPC_E;
BarCode1.Code := '173559';
BarCode1.SupplementalCode := '';
BarCode1.PaintToCanvasSize(Printer.Canvas, 0.5, 1.5, 0.5);
BarCode1.SupplementalCode := '12';
BarCode1.PaintToCanvasSize(Printer.Canvas, 3.0, 1.5, 0.5);
BarCode1.SupplementalCode := '12345';
BarCode1.PaintToCanvasSize(Printer.Canvas, 6.0, 1.5, 0.5);
BarCode1.BarcodeType := bcEAN_13;
BarCode1.Code := '737622135746';
BarCode1.SupplementalCode := '';
BarCode1.PaintToCanvasSize(Printer.Canvas, 0.5, 2.5, 0.5);
BarCode1.SupplementalCode := '12';
BarCode1.PaintToCanvasSize(Printer.Canvas, 3.0, 2.5, 0.5);
BarCode1.SupplementalCode := '12345';
BarCode1.PaintToCanvasSize(Printer.Canvas, 6.0, 2.5, 0.5);
BarCode1.BarcodeType := bcEAN_8;
BarCode1.Code := '1234567';
BarCode1.SupplementalCode := '';
BarCode1.PaintToCanvasSize(Printer.Canvas, 0.5, 3.5, 0.5);
BarCode1.SupplementalCode := '12';
BarCode1.PaintToCanvasSize(Printer.Canvas, 3.0, 3.5, 0.5);
BarCode1.SupplementalCode := '12345';
BarCode1.PaintToCanvasSize(Printer.Canvas, 6.0, 3.5, 0.5);
BarCode2.BarcodeType := bcInterleaved2of5;
BarCode2.Code := '0123456789';
BarCode2.PaintToCanvasSize(Printer.Canvas, 0.5, 4.5, 0.5);
BarCode3.BarCodeType := bcCodabar;
BarCode3.Code := 'c1234567890d';
BarCode3.PaintToCanvasSize(Printer.Canvas, 3.0, 4.5, 0.5);
BarCode4.BarCodeType := bcCode11;
BarCode4.Code := '0123456-12';
BarCode4.PaintToCanvasSize(Printer.Canvas, 5.0, 4.5, 0.5);
BarCode5.BarCodeType := bcCode39;
BarCode5.Code := '1234567890ABCDEFG';
BarCode5.PaintToCanvasSize(Printer.Canvas, 0.5, 5.5, 0.5);
BarCode5.Code := '4-976 SUGARLOAF HWY';
BarCode5.PaintToCanvasSize(Printer.Canvas, 4.5, 5.5, 0.5);
BarCode6.BarCodeType := bcCode93;
BarCode6.Code := 'CODE 93';
BarCode6.PaintToCanvasSize(Printer.Canvas, 0.5, 6.5, 0.5);
BarCode7.BarCodeType := bcCode128;
BarCode7.Code128Subset := csCodeA;
BarCode7.Code := 'CODE 128';
BarCode7.Validate(True);
BarCode7.PaintToCanvasSize(Printer.Canvas, 3.0, 6.5, 0.5);
StMaxiCodeBarcode1.Mode := cmMode5;
StMaxiCodeBarcode1.Code := 'MaxiCode';
StMaxiCodeBarcode1.Caption := 'MaxiCode';
StMaxiCodeBarcode1.PaintToPrinterCanvasSize (Printer.Canvas, 0.5, 7.5, 1);
StPDF417Barcode1.Code := 'PDF417';
StPDF417Barcode1.Caption := 'PDF417';
StPDF417Barcode1.PaintToPrinterCanvasSize (Printer.Canvas, 3.0, 7.5, 1);
finally
if not Printer.Aborted then
Printer.EndDoc;
end;
finally
Screen.Cursor := crDefault;
end;
end;
procedure TBarCodeForm.btnCopyClick(Sender: TObject);
begin
case NB.PageIndex of
0 : BarCode1.CopyToClipboard;
1 : BarCode2.CopyToClipboard;
2 : BarCode3.CopyToClipboard;
3 : BarCode4.CopyToClipboard;
4 : BarCode5.CopyToClipboard;
5 : BarCode6.CopyToClipboard;
6 : BarCode7.CopyToClipboard;
7 : StPDF417Barcode1.CopyToClipboard;
8 : StMaxiCodeBarcode1.CopyToClipboard;
end;
end;
procedure TBarCodeForm.btnValidateClick(Sender: TObject);
begin
case NB.PageIndex of
0 : BarCode1.Validate(True);
1 : BarCode2.Validate(True);
2 : BarCode3.Validate(True);
3 : BarCode4.Validate(True);
4 : BarCode5.Validate(True);
5 : BarCode6.Validate(True);
6 : BarCode7.Validate(True);
end;
end;
procedure TBarCodeForm.FormCreate(Sender: TObject);
procedure PostDataset(ACustNo: Integer; ACompany: String);
begin
with BufDataset1 do begin
Append;
FieldByName('CustNo').AsInteger := ACustNo;
FieldByName('Company').AsString := ACompany;
Post;
end;
end;
begin
BufDataset1.FieldDefs.Add('CustNo', ftInteger);
BufDataset1.FieldDefs.Add('Company', ftString, 32);
BufDataset1.CreateDataset;
BufDataset1.Active := true;
PostDataset(1221, 'Kauai Dive Shoppe');
PostDataset(1231, 'Unisco');
PostDataset(1351, 'Sight Diver');
PostDataset(1354, 'Cayman Divers World Unlimited');
PostDataset(1356, 'Tom Sawyer Diving Centre');
PostDataset(1380, 'Blue Jack Aqua Center');
PostDataset(1384, 'VIP Divers Club');
PostDataset(1510, 'Ocean Paradise');
PostDataset(1513, 'Fantastique Aquatica');
PostDataset(1551, 'Marmot Divers Club');
PostDataset(1560, 'The Depth Charge');
PostDataset(1563, 'Blue Sports');
PostDataset(1624, 'Makai SCUBA Club');
PostDataset(1645, 'Action Club');
PostDataset(1651, 'Jamaica SCUBA Centre');
end;
procedure TBarCodeForm.btnCloseClick(Sender: TObject);
begin
Close;
end;
procedure TBarCodeForm.btnSaveClick(Sender: TObject);
begin
case NB.PageIndex of
0 : BarCode1.SaveToFile('UPCEAN.bmp');
1 : BarCode2.SaveToFile('I2of5.bmp');
2 : BarCode3.SaveToFile('Codabar.bmp');
3 : BarCode4.SaveToFile('Code11.bmp');
4 : BarCode5.SaveToFile('Code39.bmp');
5 : BarCode6.SaveToFile('Code93.bmp');
6 : BarCode7.SaveToFile('Code128.bmp');
7 : StPDF417Barcode1.SaveToFile ('PDF417.bmp');
8 : StMaxiCodeBarcode1.SaveToFile ('MaxiCode.bmp');
end;
end;
procedure TBarCodeForm.btnUpdate1Click(Sender: TObject);
begin
case rgType.ItemIndex of
0 : begin
BarCode1.BarcodeType := bcUPC_A;
edCode1.MaxLength := 12;
edCode1.Text := Copy(edCode1.Text, 1, 12);
Label1.Caption := 'Code: 11 or 12 Numeric ';
end;
1 : begin
BarCode1.BarcodeType := bcUPC_E;
edCode1.MaxLength := 6;
Label1.Caption := 'Code: 6 Numeric ';
edCode1.Text := Copy(edCode1.Text, 1, 6);
end;
2 : begin
BarCode1.BarcodeType := bcEAN_13;
edCode1.MaxLength := 13;
Label1.Caption := 'Code: 12 or 13 Numeric ';
edCode1.Text := Copy(edCode1.Text, 1, 13);
end;
3 : begin
BarCode1.BarcodeType := bcEAN_8;
edCode1.MaxLength := 8;
Label1.Caption := 'Code: 7 or 8 Numeric ';
edCode1.Text := Copy(edCode1.Text, 1, 8);
end;
end;
BarCode1.ShowCode := cbShowCode.Checked;
BarCode1.TallGuardBars := cbTallGuardBars.Checked;
BarCode1.Code := edCode1.Text;
if cbSupp.Checked then begin
BarCode1.SupplementalCode := edSupp.Text;
edSupp.Enabled := True;
end else begin
BarCode1.SupplementalCode := '';
edSupp.Enabled := False;
end;
end;
procedure TBarCodeForm.btnUpdate2Click(Sender: TObject);
begin
BarCode2.Code := edCode2.Text;
BarCode2.ShowCode := cbShowCode2.Checked;
BarCode2.BearerBars := cbBearerBars.Checked;
end;
procedure TBarCodeForm.btnUpdate3Click(Sender: TObject);
begin
BarCode3.Code := edCode3.Text;
BarCode3.ShowCode := cbShowCode3.Checked;
BarCode3.ShowGuardChars := cbShowGuardChars3.Checked;
end;
procedure TBarCodeForm.btnUpdate4Click(Sender: TObject);
begin
BarCode4.Code := edCode4.Text;
BarCode4.ShowCode := cbShowCode4.Checked;
end;
procedure TBarCodeForm.btnUpdate5Click(Sender: TObject);
begin
BarCode5.Code := edCode5.Text;
BarCode5.ShowCode := cbShowCode5.Checked;
end;
procedure TBarCodeForm.btnUpdate6Click(Sender: TObject);
begin
BarCode6.Code := edCode6.Text;
BarCode6.ShowCode := cbShowCode6.Checked;
end;
procedure TBarCodeForm.btnUpdate7Click(Sender: TObject);
begin
BarCode7.Code := edCode7.Text;
BarCode7.ShowCode := cbShowCode7.Checked;
end;
procedure TBarCodeForm.btnUpdatePDF417Click(Sender: TObject);
begin
StPDF417Barcode1.Truncated := cbPDF417Truncated.Checked;
StPDF417BarCode1.Code := edCodePDF417.Text;
if cbShowCodePDF417.Checked then
StPDF417BarCode1.Caption := edCodePDF417.Text
else
StPDF417BarCode1.Caption := '';
end;
procedure TBarCodeForm.btnUpdateMaxiCodeClick(Sender: TObject);
begin
StMaxiCodeBarCode1.Code := edCodeMaxiCode.Text;
StMaxiCodeBarCode1.CarrierCountryCode := StrToInt (edMCCountryCode.Text);
StMaxiCodeBarCode1.CarrierPostalCode := edMCPostalCode.Text;
StMaxiCodeBarCode1.CarrierServiceClass := StrToInt (edMCServiceClass.Text);
if cbShowCodeMaxiCode.Checked then
StMaxiCodeBarCode1.Caption := edCodeMaxiCode.Text
else
StMaxiCodeBarCode1.Caption := '';
end;
procedure TBarCodeForm.radMCMode4Click(Sender: TObject);
begin
edMCServiceClass.Enabled := False;
edMCPostalCode.Enabled := False;
edMCCountryCode.Enabled := False;
StMaxiCodeBarCode1.Mode := cmMode4;
btnUpdateMaxiCodeClick (Sender);
end;
procedure TBarCodeForm.radMCMode23Click(Sender: TObject);
begin
edMCServiceClass.Enabled := True;
edMCPostalCode.Enabled := True;
edMCCountryCode.Enabled := True;
StMaxiCodeBarCode1.Mode := cmMode2;
btnUpdateMaxiCodeClick (Sender);
end;
procedure TBarCodeForm.radMCMode5Click(Sender: TObject);
begin
edMCServiceClass.Enabled := False;
edMCPostalCode.Enabled := False;
edMCCountryCode.Enabled := False;
StMaxiCodeBarCode1.Mode := cmMode5;
btnUpdateMaxiCodeClick (Sender);
end;
procedure TBarCodeForm.NBChange(Sender: TObject; NewTab: Integer;
var AllowChange: Boolean);
begin
if (NewTab = 7) or (NewTab = 8) then
btnValidate.Enabled := False
else
btnValidate.Enabled := True;
end;
end.

87
components/systools/examples/barcode/Exbarc.lpi Normal file
View File

@ -0,0 +1,87 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="Exbarc"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<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="5">
<Item1>
<PackageName Value="FCL"/>
</Item1>
<Item2>
<PackageName Value="Printer4Lazarus"/>
</Item2>
<Item3>
<PackageName Value="laz_systoolsdb"/>
</Item3>
<Item4>
<PackageName Value="laz_systools"/>
</Item4>
<Item5>
<PackageName Value="LCL"/>
</Item5>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="Exbarc.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ExBarC"/>
</Unit0>
<Unit1>
<Filename Value="ExBarCU.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="BarCodeForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="Exbarc"/>
</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>

40
components/systools/examples/barcode/Exbarc.lpr Normal file
View File

@ -0,0 +1,40 @@
(* ***** 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 ***** *)
program ExBarC;
uses
Interfaces,
Forms, printer4lazarus,
ExBarCU in 'ExBarCU.pas' {BarCodeForm};
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TBarCodeForm, BarCodeForm);
Application.Run;
end.

86
components/systools/examples/expression/exexpr.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="exexpr"/>
<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="exexpr.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ExExpr"/>
</Unit0>
<Unit1>
<Filename Value="exexpru.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="StDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="ExExprU"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="exexpr"/>
</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>

41
components/systools/examples/expression/exexpr.lpr Normal file
View File

@ -0,0 +1,41 @@
(* ***** 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 ***** *)
program ExExpr;
uses
Forms, Interfaces, lclversion,
ExExprU in 'ExExprU.pas' {StDlg};
{$R *.res}
begin
{$IF lcl_fullversion >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TStDlg, StDlg);
Application.Run;
end.

477
components/systools/examples/expression/exexpru.lfm Normal file
View File

@ -0,0 +1,477 @@
object StDlg: TStDlg
Left = 693
Height = 270
Top = 379
Width = 462
BorderStyle = bsDialog
Caption = 'Expression Evaluator (StExpr) Example'
ClientHeight = 270
ClientWidth = 462
Color = clBtnFace
Font.Color = clWindowText
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 16
Height = 15
Top = 16
Width = 128
Caption = 'Expression to evaluate:'
Font.Color = clWindowText
Font.Style = [fsBold]
ParentColor = False
ParentFont = False
end
object Label2: TLabel
Left = 16
Height = 15
Top = 63
Width = 38
Caption = 'Result:'
Font.Color = clWindowText
Font.Style = [fsBold]
ParentColor = False
ParentFont = False
end
object Panel2: TPanel
Left = 204
Height = 141
Top = 112
Width = 165
BevelOuter = bvLowered
ClientHeight = 141
ClientWidth = 165
TabOrder = 4
object DivBtn: TBitBtn
Left = 123
Height = 28
Top = 9
Width = 35
Caption = '/'
Font.Color = clRed
OnClick = DivBtnClick
ParentFont = False
TabOrder = 15
end
object MulBtn: TBitBtn
Left = 123
Height = 28
Top = 42
Width = 35
Caption = '*'
Font.Color = clRed
OnClick = MulBtnClick
ParentFont = False
TabOrder = 14
end
object MinusBtn: TBitBtn
Left = 123
Height = 28
Top = 74
Width = 35
Caption = '-'
Font.Color = clRed
OnClick = MinusBtnClick
ParentFont = False
TabOrder = 13
end
object PlusBtn: TBitBtn
Left = 123
Height = 28
Top = 107
Width = 35
Caption = '+'
Font.Color = clRed
OnClick = PlusBtnClick
ParentFont = False
TabOrder = 12
end
object EBtn: TBitBtn
Left = 45
Height = 28
Top = 107
Width = 35
Caption = 'E'
Font.Color = clBlue
OnClick = EBtnClick
ParentFont = False
TabOrder = 11
end
object Nr3Btn: TBitBtn
Left = 84
Height = 28
Top = 74
Width = 35
Caption = '3'
Font.Color = clBlue
OnClick = Nr3BtnClick
ParentFont = False
TabOrder = 3
end
object Nr6Btn: TBitBtn
Left = 84
Height = 28
Top = 42
Width = 35
Caption = '6'
Font.Color = clBlue
OnClick = Nr6BtnClick
ParentFont = False
TabOrder = 6
end
object Nr9Btn: TBitBtn
Left = 84
Height = 28
Top = 9
Width = 35
Caption = '9'
Font.Color = clBlue
OnClick = Nr9BtnClick
ParentFont = False
TabOrder = 9
end
object DotBtn: TBitBtn
Left = 84
Height = 28
Top = 107
Width = 35
Caption = '.'
Font.Color = clBlue
OnClick = DotBtnClick
ParentFont = False
TabOrder = 10
end
object Nr2Btn: TBitBtn
Left = 45
Height = 28
Top = 74
Width = 35
Caption = '2'
Font.Color = clBlue
OnClick = Nr2BtnClick
ParentFont = False
TabOrder = 2
end
object Nr5Btn: TBitBtn
Left = 45
Height = 28
Top = 42
Width = 35
Caption = '5'
Font.Color = clBlue
OnClick = Nr5BtnClick
ParentFont = False
TabOrder = 5
end
object Nr8Btn: TBitBtn
Left = 45
Height = 28
Top = 9
Width = 35
Caption = '8'
Font.Color = clBlue
OnClick = Nr8BtnClick
ParentFont = False
TabOrder = 8
end
object Nr0Btn: TBitBtn
Left = 6
Height = 28
Top = 107
Width = 35
Caption = '0'
Font.Color = clBlue
OnClick = Nr0BtnClick
ParentFont = False
TabOrder = 0
end
object Nr1Btn: TBitBtn
Left = 6
Height = 28
Top = 74
Width = 35
Caption = '1'
Font.Color = clBlue
OnClick = Nr1BtnClick
ParentFont = False
TabOrder = 1
end
object Nr4Btn: TBitBtn
Left = 6
Height = 28
Top = 42
Width = 35
Caption = '4'
Font.Color = clBlue
OnClick = Nr4BtnClick
ParentFont = False
TabOrder = 4
end
object Nr7Btn: TBitBtn
Left = 6
Height = 28
Top = 9
Width = 35
Caption = '7'
Font.Color = clBlue
OnClick = Nr7BtnClick
ParentFont = False
TabOrder = 7
end
end
object Panel1: TPanel
Left = 24
Height = 141
Top = 112
Width = 169
BevelOuter = bvLowered
ClientHeight = 141
ClientWidth = 169
TabOrder = 5
object SqrtBtn: TBitBtn
Left = 48
Height = 28
Top = 106
Width = 35
Caption = 'sqrt'
Font.Color = clFuchsia
Font.Height = -11
OnClick = SqrtBtnClick
ParentFont = False
TabOrder = 9
end
object PiBtn: TBitBtn
Left = 9
Height = 28
Top = 9
Width = 35
Caption = 'pi'
Font.Color = clFuchsia
Font.Height = -11
OnClick = PiBtnClick
ParentFont = False
TabOrder = 15
end
object ExpBtn: TBitBtn
Left = 87
Height = 28
Top = 74
Width = 35
Caption = 'Exp'
Font.Color = clFuchsia
Font.Height = -11
OnClick = ExpBtnClick
ParentFont = False
TabOrder = 7
end
object PowerBtn: TBitBtn
Left = 48
Height = 28
Top = 41
Width = 35
Caption = '^'
Font.Color = clFuchsia
Font.Height = -11
OnClick = PowerBtnClick
ParentFont = False
TabOrder = 11
end
object CommaBtn: TBitBtn
Left = 126
Height = 28
Top = 9
Width = 35
Caption = ','
Enabled = False
Font.Color = clFuchsia
Font.Height = -11
OnClick = CommaBtnClick
ParentFont = False
TabOrder = 2
end
object CosBtn: TBitBtn
Left = 9
Height = 28
Top = 73
Width = 35
Caption = 'cos'
Font.Color = clFuchsia
Font.Height = -11
OnClick = CosBtnClick
ParentFont = False
TabOrder = 13
end
object LnBtn: TBitBtn
Left = 87
Height = 28
Top = 42
Width = 35
Caption = 'ln'
Font.Color = clFuchsia
Font.Height = -11
OnClick = LnBtnClick
ParentFont = False
TabOrder = 8
end
object SqrBtn: TBitBtn
Left = 48
Height = 28
Top = 74
Width = 35
Caption = 'sqr'
Font.Color = clFuchsia
Font.Height = -11
OnClick = SqrBtnClick
ParentFont = False
TabOrder = 10
end
object RParBtn: TBitBtn
Left = 87
Height = 28
Top = 9
Width = 35
Caption = ')'
Font.Color = clFuchsia
Font.Height = -11
OnClick = RParBtnClick
ParentFont = False
TabOrder = 1
end
object ArctanBtn: TBitBtn
Left = 9
Height = 28
Top = 106
Width = 35
Caption = 'arctan'
Font.Color = clFuchsia
Font.Height = -11
OnClick = ArctanBtnClick
ParentFont = False
TabOrder = 12
end
object IntBtn: TBitBtn
Left = 126
Height = 28
Top = 106
Width = 35
Caption = 'int'
Font.Color = clFuchsia
Font.Height = -11
OnClick = IntBtnClick
ParentFont = False
TabOrder = 3
end
object SinBtn: TBitBtn
Left = 9
Height = 28
Top = 41
Width = 35
Caption = 'sin'
Font.Color = clFuchsia
Font.Height = -11
OnClick = SinBtnClick
ParentFont = False
TabOrder = 14
end
object LParBtn: TBitBtn
Left = 48
Height = 28
Top = 9
Width = 35
Caption = '('
Font.Color = clFuchsia
Font.Height = -11
OnClick = LParBtnClick
ParentFont = False
TabOrder = 0
end
object AbsBtn: TBitBtn
Left = 87
Height = 28
Top = 106
Width = 35
Caption = 'abs'
Font.Color = clFuchsia
Font.Height = -11
OnClick = AbsBtnClick
ParentFont = False
TabOrder = 6
end
object FracBtn: TBitBtn
Left = 126
Height = 28
Top = 74
Width = 35
Caption = 'frac'
Font.Color = clFuchsia
Font.Height = -11
OnClick = FracBtnClick
ParentFont = False
TabOrder = 4
end
object RoundBtn: TBitBtn
Left = 126
Height = 28
Top = 41
Width = 35
Caption = 'round'
Font.Color = clFuchsia
Font.Height = -11
OnClick = RoundBtnClick
ParentFont = False
TabOrder = 5
end
end
object ResultEdit: TEdit
Left = 16
Height = 23
Top = 79
Width = 432
Color = clBtnFace
ReadOnly = True
TabStop = False
TabOrder = 6
end
object EvaluateBtn: TBitBtn
Left = 380
Height = 25
Top = 116
Width = 65
Caption = 'Evaluate'
Default = True
Font.Color = clMaroon
OnClick = EvaluateBtnClick
ParentFont = False
TabOrder = 1
end
object ClearBtn: TBitBtn
Left = 380
Height = 25
Top = 148
Width = 65
Caption = 'Clear'
Font.Color = clMaroon
OnClick = ClearBtnClick
ParentFont = False
TabOrder = 2
end
object ExprEdit: TStExpressionEdit
Left = 16
Height = 23
Top = 32
Width = 433
TabOrder = 0
OnError = ExprEditError
end
object BSBtn: TBitBtn
Left = 380
Height = 25
Top = 180
Width = 65
Caption = 'Backspace'
Font.Color = clMaroon
OnClick = BSBtnClick
ParentFont = False
TabOrder = 3
end
end

368
components/systools/examples/expression/exexpru.pas Normal file
View File

@ -0,0 +1,368 @@
(* ***** 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 ***** *)
{$mode delphi}
unit ExExprU;
interface
uses
{$IFDEF FPC}
// LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, ExtCtrls, Buttons, StdCtrls,
StBase, StConst, StExpr;
type
TStDlg = class(TForm)
Label1: TLabel;
ResultEdit: TEdit;
Label2: TLabel;
EvaluateBtn: TBitBtn;
ClearBtn: TBitBtn;
Panel1: TPanel;
Panel2: TPanel;
ExprEdit: TStExpressionEdit;
DivBtn: TBitBtn;
MulBtn: TBitBtn;
MinusBtn: TBitBtn;
PlusBtn: TBitBtn;
EBtn: TBitBtn;
Nr3Btn: TBitBtn;
Nr6Btn: TBitBtn;
Nr9Btn: TBitBtn;
DotBtn: TBitBtn;
Nr2Btn: TBitBtn;
Nr5Btn: TBitBtn;
Nr8Btn: TBitBtn;
Nr0Btn: TBitBtn;
Nr1Btn: TBitBtn;
Nr4Btn: TBitBtn;
Nr7Btn: TBitBtn;
SqrtBtn: TBitBtn;
PiBtn: TBitBtn;
ExpBtn: TBitBtn;
PowerBtn: TBitBtn;
CommaBtn: TBitBtn;
CosBtn: TBitBtn;
LnBtn: TBitBtn;
SqrBtn: TBitBtn;
RParBtn: TBitBtn;
ArctanBtn: TBitBtn;
IntBtn: TBitBtn;
SinBtn: TBitBtn;
LParBtn: TBitBtn;
AbsBtn: TBitBtn;
FracBtn: TBitBtn;
RoundBtn: TBitBtn;
BSBtn: TBitBtn;
procedure LParBtnClick(Sender: TObject);
procedure RParBtnClick(Sender: TObject);
procedure CommaBtnClick(Sender: TObject);
procedure PowerBtnClick(Sender: TObject);
procedure AbsBtnClick(Sender: TObject);
procedure ArctanBtnClick(Sender: TObject);
procedure CosBtnClick(Sender: TObject);
procedure ExpBtnClick(Sender: TObject);
procedure FracBtnClick(Sender: TObject);
procedure IntBtnClick(Sender: TObject);
procedure LnBtnClick(Sender: TObject);
procedure PiBtnClick(Sender: TObject);
procedure RoundBtnClick(Sender: TObject);
procedure SinBtnClick(Sender: TObject);
procedure SqrBtnClick(Sender: TObject);
procedure SqrtBtnClick(Sender: TObject);
procedure Nr0BtnClick(Sender: TObject);
procedure Nr1BtnClick(Sender: TObject);
procedure Nr2BtnClick(Sender: TObject);
procedure Nr3BtnClick(Sender: TObject);
procedure Nr4BtnClick(Sender: TObject);
procedure Nr5BtnClick(Sender: TObject);
procedure Nr6BtnClick(Sender: TObject);
procedure Nr7BtnClick(Sender: TObject);
procedure Nr8BtnClick(Sender: TObject);
procedure Nr9BtnClick(Sender: TObject);
procedure DotBtnClick(Sender: TObject);
procedure EBtnClick(Sender: TObject);
procedure PlusBtnClick(Sender: TObject);
procedure MinusBtnClick(Sender: TObject);
procedure MulBtnClick(Sender: TObject);
procedure DivBtnClick(Sender: TObject);
procedure EvaluateBtnClick(Sender: TObject);
procedure ClearBtnClick(Sender: TObject);
procedure ExprEditError(Sender: TObject; ErrorNumber: Longint;
const ErrorStr: String);
procedure BSBtnClick(Sender: TObject);
private
procedure AddExpr(Add : string; Parens : Boolean);
end;
var
StDlg: TStDlg;
implementation
{$R *.lfm}
procedure TStDlg.AddExpr(add : string; parens : boolean);
var
position, sellen : integer;
temp : string;
begin
position := ExprEdit.SelStart+1;
sellen := ExprEdit.SelLength;
temp := ExprEdit.Text;
if (parens) then begin
add := add+'(';
if (sellen > 0) then
{surround the selection with the parentheses}
insert(')', temp, position+sellen)
else
add := add+')';
end;
insert(add, temp, position);
ExprEdit.Text := temp;
ExprEdit.SetFocus;
if (parens) then begin
if (sellen > 0) then
{position after the add}
ExprEdit.SelStart := position+sellen+length(add)
else
{position before last parenthesis}
ExprEdit.SelStart := position+length(add)-2;
end else
{position after the add}
ExprEdit.SelStart := position+length(add)-1;
ExprEdit.SelLength := 0;
end;
procedure TStDlg.LParBtnClick(Sender: TObject);
begin
AddExpr('(', False);
end;
procedure TStDlg.RParBtnClick(Sender: TObject);
begin
AddExpr(')', False);
end;
procedure TStDlg.CommaBtnClick(Sender: TObject);
begin
AddExpr(ListSeparator, False);
end;
procedure TStDlg.PowerBtnClick(Sender: TObject);
begin
AddExpr('^', False);
end;
procedure TStDlg.AbsBtnClick(Sender: TObject);
begin
AddExpr('abs', True);
end;
procedure TStDlg.ArctanBtnClick(Sender: TObject);
begin
AddExpr('arctan', True);
end;
procedure TStDlg.CosBtnClick(Sender: TObject);
begin
AddExpr('cos', True);
end;
procedure TStDlg.ExpBtnClick(Sender: TObject);
begin
AddExpr('exp', True);
end;
procedure TStDlg.FracBtnClick(Sender: TObject);
begin
AddExpr('frac', True);
end;
procedure TStDlg.IntBtnClick(Sender: TObject);
begin
AddExpr('int', True);
end;
procedure TStDlg.LnBtnClick(Sender: TObject);
begin
AddExpr('ln', True);
end;
procedure TStDlg.PiBtnClick(Sender: TObject);
begin
AddExpr('pi', False);
end;
procedure TStDlg.RoundBtnClick(Sender: TObject);
begin
AddExpr('round', True);
end;
procedure TStDlg.SinBtnClick(Sender: TObject);
begin
AddExpr('sin', True);
end;
procedure TStDlg.SqrBtnClick(Sender: TObject);
begin
AddExpr('sqr', True);
end;
procedure TStDlg.SqrtBtnClick(Sender: TObject);
begin
AddExpr('sqrt', True);
end;
procedure TStDlg.Nr0BtnClick(Sender: TObject);
begin
AddExpr('0', False);
end;
procedure TStDlg.Nr1BtnClick(Sender: TObject);
begin
AddExpr('1', False);
end;
procedure TStDlg.Nr2BtnClick(Sender: TObject);
begin
AddExpr('2', False);
end;
procedure TStDlg.Nr3BtnClick(Sender: TObject);
begin
AddExpr('3', False);
end;
procedure TStDlg.Nr4BtnClick(Sender: TObject);
begin
AddExpr('4', False);
end;
procedure TStDlg.Nr5BtnClick(Sender: TObject);
begin
AddExpr('5', False);
end;
procedure TStDlg.Nr6BtnClick(Sender: TObject);
begin
AddExpr('6', False);
end;
procedure TStDlg.Nr7BtnClick(Sender: TObject);
begin
AddExpr('7', False);
end;
procedure TStDlg.Nr8BtnClick(Sender: TObject);
begin
AddExpr('8', False);
end;
procedure TStDlg.Nr9BtnClick(Sender: TObject);
begin
AddExpr('9', False);
end;
procedure TStDlg.DotBtnClick(Sender: TObject);
begin
AddExpr(DecimalSeparator, False);
end;
procedure TStDlg.EBtnClick(Sender: TObject);
begin
AddExpr('E', False);
end;
procedure TStDlg.PlusBtnClick(Sender: TObject);
begin
AddExpr('+', False);
end;
procedure TStDlg.MinusBtnClick(Sender: TObject);
begin
AddExpr('-', False);
end;
procedure TStDlg.MulBtnClick(Sender: TObject);
begin
AddExpr('*', False);
end;
procedure TStDlg.DivBtnClick(Sender: TObject);
begin
AddExpr('/', False);
end;
procedure TStDlg.EvaluateBtnClick(Sender: TObject);
var
res : double;
begin
res := ExprEdit.Evaluate;
if ExprEdit.Expr.LastError = 0 then
ResultEdit.Text := FloatToStr(res);
ExprEdit.SetFocus;
end;
procedure TStDlg.ClearBtnClick(Sender: TObject);
begin
ExprEdit.Text := '';
ResultEdit.Text := '';
ExprEdit.SetFocus;
end;
procedure TStDlg.ExprEditError(Sender: TObject; ErrorNumber: Longint;
const ErrorStr: String);
begin
ResultEdit.Text := 'Error ' + IntToStr(ErrorNumber) + ': ' + ErrorStr;
end;
procedure TStDlg.BSBtnClick(Sender: TObject);
var
s: String;
p: Integer;
begin
s := ExprEdit.Text;
p := ExprEdit.CaretPos.X;
Delete(s, p, 1);
ExprEdit.Text := s;
ExprEdit.SetFocus;
if p = 0 then
Expredit.SelStart := 0
else
ExprEdit.SelStart := p - 1;
end;
end.

516
components/systools/examples/financial_calculator/fincalu.lfm Normal file
View File

@ -0,0 +1,516 @@
object FinCalForm: TFinCalForm
Left = 197
Height = 674
Top = 59
Width = 754
VertScrollBar.Range = 1000
VertScrollBar.Visible = False
Caption = 'Financial Calculator'
ClientHeight = 674
ClientWidth = 754
Color = clBtnFace
Font.Color = clNavy
OnCreate = FormCreate
Position = poScreenCenter
LCLVersion = '1.9.0.0'
Visible = True
object Functions: TRadioGroup
Left = 8
Height = 265
Top = 8
Width = 553
AutoFill = True
Caption = 'Functions'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 3
ClientHeight = 245
ClientWidth = 549
Columns = 3
Items.Strings = (
'AccruedInterestMaturity'
'AccruedInterestPeriodic'
'BondDuration'
'BondPrice'
'CumulativeInterest'
'CumulativePrincipal'
'DecliningBalance'
'DiscountRate'
'DollarToDecimal'
'DollarToDecimalText'
'DollarToFraction'
'DollarToFractionStr'
'EffectiveInterestRate'
'FutureValue'
'FutureValueSchedule'
'InterestRate'
'InternalRateOfReturn'
'IsCardValid'
'ModifiedDuration'
'ModifiedIRR'
'NetPresentValue'
'NominalInterestRate'
'NonPeriodicIRR'
'NonPeriodicNPV'
'Payment'
'PresentValue'
'ReceivedAtMaturity'
'RoundToDecimal'
'TBillEquivYield'
'TBillPrice'
'TBillYield'
'VariableDecliningBalance'
'YieldPeriodic'
'YieldDiscounted'
'YieldMaturity'
)
OnClick = FunctionsClick
TabOrder = 0
TabStop = True
end
object GroupBox1: TGroupBox
Left = 8
Height = 272
Top = 280
Width = 553
Caption = 'Arguments'
ClientHeight = 252
ClientWidth = 549
TabOrder = 1
object Label2: TLabel
Left = 29
Height = 15
Top = 48
Width = 6
Caption = '1'
ParentColor = False
end
object Label4: TLabel
Left = 29
Height = 15
Top = 80
Width = 6
Caption = '2'
ParentColor = False
end
object Label5: TLabel
Left = 29
Height = 15
Top = 112
Width = 6
Caption = '3'
ParentColor = False
end
object Label6: TLabel
Left = 29
Height = 15
Top = 144
Width = 6
Caption = '4'
ParentColor = False
end
object Label7: TLabel
Left = 21
Height = 15
Top = 216
Width = 31
Caption = 'String'
ParentColor = False
end
object Label3: TLabel
Left = 342
Height = 15
Top = 24
Width = 24
Caption = 'Date'
ParentColor = False
end
object Label1: TLabel
Left = 237
Height = 15
Top = 24
Width = 37
Caption = 'Integer'
ParentColor = False
end
object Label20: TLabel
Left = 109
Height = 15
Top = 24
Width = 48
Caption = 'Extended'
ParentColor = False
end
object Label10: TLabel
Left = 438
Height = 15
Top = 24
Width = 75
Caption = 'Miscellaneous'
ParentColor = False
end
object Label13: TLabel
Left = 29
Height = 15
Top = 176
Width = 6
Caption = '5'
ParentColor = False
end
object StrEdit: TEdit
Left = 69
Height = 23
Top = 216
Width = 468
Enabled = False
MaxLength = 80
OnExit = StrEditExit
ParentShowHint = False
ShowHint = True
TabOrder = 19
end
object E1Edit: TEdit
Tag = 1
Left = 69
Height = 23
Top = 48
Width = 130
Enabled = False
OnExit = ExtEditExit
TabOrder = 0
end
object E2Edit: TEdit
Tag = 2
Left = 69
Height = 23
Top = 80
Width = 130
Enabled = False
OnExit = ExtEditExit
TabOrder = 1
end
object E3Edit: TEdit
Tag = 3
Left = 69
Height = 23
Top = 112
Width = 130
Enabled = False
OnExit = ExtEditExit
TabOrder = 2
end
object E4Edit: TEdit
Tag = 4
Left = 69
Height = 23
Top = 144
Width = 130
Color = clWhite
Enabled = False
OnExit = ExtEditExit
TabOrder = 3
end
object I1Edit: TEdit
Tag = 1
Left = 221
Height = 23
Top = 48
Width = 73
Enabled = False
OnExit = IntEditExit
TabOrder = 5
end
object I2Edit: TEdit
Tag = 2
Left = 221
Height = 23
Top = 80
Width = 73
Enabled = False
OnExit = IntEditExit
TabOrder = 6
end
object I3Edit: TEdit
Tag = 3
Left = 221
Height = 23
Top = 112
Width = 73
Enabled = False
OnExit = IntEditExit
TabOrder = 7
end
object I4Edit: TEdit
Tag = 4
Left = 221
Height = 23
Top = 144
Width = 73
Enabled = False
OnExit = IntEditExit
TabOrder = 8
end
object D1Edit: TEdit
Tag = 1
Left = 317
Height = 23
Top = 48
Width = 73
Color = clWhite
Enabled = False
OnExit = DateEditExit
TabOrder = 10
end
object D2Edit: TEdit
Tag = 2
Left = 317
Height = 23
Top = 80
Width = 73
Color = clWhite
Enabled = False
OnExit = DateEditExit
TabOrder = 11
end
object D3Edit: TEdit
Tag = 3
Left = 317
Height = 23
Top = 112
Width = 73
Color = clWhite
Enabled = False
OnExit = DateEditExit
TabOrder = 12
end
object D4Edit: TEdit
Tag = 4
Left = 317
Height = 23
Top = 144
Width = 73
Color = clWhite
Enabled = False
OnExit = DateEditExit
TabOrder = 13
end
object FreqEdit: TComboBox
Left = 416
Height = 23
Top = 48
Width = 121
DropDownCount = 4
ItemHeight = 15
Items.Strings = (
'Annual'
'SemiAnnual'
'Quarterly'
'Monthly'
)
OnExit = FreqEditExit
Style = csDropDownList
TabOrder = 15
end
object BasEdit: TComboBox
Left = 416
Height = 23
Top = 80
Width = 121
DropDownCount = 6
ItemHeight = 15
Items.Strings = (
'30/360 NASD'
'ACT/ACT'
'ACT/360'
'ACT/365'
'30/360 EUR'
'30/360 PSA'
)
OnExit = BasEditExit
Style = csDropDownList
TabOrder = 16
end
object TimEdit: TComboBox
Left = 416
Height = 23
Top = 112
Width = 121
DropDownCount = 2
ItemHeight = 15
Items.Strings = (
'End of Period'
'Start of Period'
)
OnExit = TimEditExit
Style = csDropDownList
TabOrder = 17
end
object E5Edit: TEdit
Tag = 5
Left = 69
Height = 23
Top = 176
Width = 130
Color = clWhite
Enabled = False
OnExit = ExtEditExit
TabOrder = 4
end
object I5Edit: TEdit
Tag = 5
Left = 221
Height = 23
Top = 176
Width = 73
Enabled = False
OnExit = IntEditExit
TabOrder = 9
end
object D5Edit: TEdit
Tag = 5
Left = 317
Height = 23
Top = 176
Width = 73
Color = clWhite
Enabled = False
OnExit = DateEditExit
TabOrder = 14
end
object BoolEdit: TCheckBox
Left = 424
Height = 19
Top = 152
Width = 75
Caption = 'True/False'
OnExit = BoolEditExit
TabOrder = 18
end
end
object Arrays: TGroupBox
Left = 568
Height = 536
Top = 8
Width = 177
Caption = 'Arrays'
ClientHeight = 516
ClientWidth = 173
TabOrder = 2
object Label8: TLabel
Left = 68
Height = 15
Top = 264
Width = 33
Caption = 'Values'
ParentColor = False
end
object Label9: TLabel
Left = 68
Height = 15
Top = 24
Width = 29
Caption = 'Dates'
ParentColor = False
end
object VAEdit: TStringGrid
Tag = 50
Left = 32
Height = 215
Top = 288
Width = 121
Color = clWhite
ColCount = 1
DefaultColWidth = 118
DefaultRowHeight = 20
FixedCols = 0
FixedRows = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goEditing, goAlwaysShowEditor]
RowCount = 30
ScrollBars = ssVertical
TabOrder = 1
TitleFont.Color = clNavy
TitleFont.Height = -13
TitleFont.Name = 'Arial'
OnEnter = VAEditEnter
OnExit = VAEditExit
end
object DAEdit: TStringGrid
Left = 32
Height = 182
Top = 48
Width = 121
Color = clWhite
ColCount = 1
DefaultColWidth = 118
DefaultRowHeight = 20
FixedCols = 0
FixedRows = 0
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goEditing, goAlwaysShowEditor]
RowCount = 30
ScrollBars = ssVertical
TabOrder = 0
TitleFont.Color = clNavy
TitleFont.Height = -13
TitleFont.Name = 'Arial'
OnEnter = DAEditEnter
OnExit = DAEditExit
end
end
object Panel1: TPanel
Left = 8
Height = 105
Top = 560
Width = 737
BevelInner = bvRaised
BevelOuter = bvLowered
ClientHeight = 105
ClientWidth = 737
TabOrder = 3
object GoBtn: TButton
Left = 248
Height = 33
Top = 60
Width = 241
Caption = 'Evaluate'
Default = True
OnClick = GoBtnClick
TabOrder = 2
end
object SResult: TEdit
Left = 184
Height = 23
Top = 25
Width = 529
Color = clAqua
ReadOnly = True
TabStop = False
TabOrder = 1
end
object BitBtn1: TBitBtn
Left = 632
Height = 33
Top = 60
Width = 81
Cancel = True
Caption = 'Close'
NumGlyphs = 2
OnClick = BitBtn1Click
TabOrder = 3
TabStop = False
end
object FResult: TEdit
Left = 24
Height = 23
Top = 24
Width = 137
Color = clAqua
ReadOnly = True
TabStop = False
TabOrder = 0
end
end
end

769
components/systools/examples/financial_calculator/fincalu.pas Normal file
View File

@ -0,0 +1,769 @@
(* ***** 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 ***** *)
unit Fincalu;
interface
uses
{$IFDEF FPC}
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Controls, Classes, Forms, StdCtrls, Buttons,
ExtCtrls, Grids, Graphics,
StFin, StDate, StDateSt;
type
TFinCalForm = class(TForm)
Functions: TRadioGroup;
GroupBox1: TGroupBox;
Label2: TLabel;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
Label7: TLabel;
Label3: TLabel;
Label1: TLabel;
Label20: TLabel;
Arrays: TGroupBox;
Label8: TLabel;
Label9: TLabel;
StrEdit: TEdit;
Panel1: TPanel;
GoBtn: TButton;
SResult: TEdit;
BitBtn1: TBitBtn;
E1Edit: TEdit;
E2Edit: TEdit;
E3Edit: TEdit;
E4Edit: TEdit;
I1Edit: TEdit;
I2Edit: TEdit;
I3Edit: TEdit;
I4Edit: TEdit;
FResult: TEdit;
VAEdit: TStringGrid;
DAEdit: TStringGrid;
D1Edit: TEdit;
D2Edit: TEdit;
D3Edit: TEdit;
D4Edit: TEdit;
Label10: TLabel;
FreqEdit: TComboBox;
BasEdit: TComboBox;
TimEdit: TComboBox;
E5Edit: TEdit;
I5Edit: TEdit;
D5Edit: TEdit;
Label13: TLabel;
BoolEdit: TCheckBox;
procedure SetupAccruedInterestPeriodic;
procedure SetupAccruedInterestMaturity;
procedure SetupCumulativeInterest;
procedure SetupCumulativePrincipal;
procedure SetupDiscountRate;
procedure SetupEffectiveInterestRate;
procedure SetupNominalInterestRate;
procedure SetupInterestRate;
procedure SetupReceivedAtMaturity;
procedure SetupYieldPeriodic;
procedure SetupYieldDiscounted;
procedure SetupYieldMaturity;
procedure SetupTBillEquivYield;
procedure SetupTBillPrice;
procedure SetupTBillYield;
procedure SetupBondDuration;
procedure SetupModifiedDuration;
procedure SetupFutureValueSCHEDULE;
procedure SetupModifiedIRR;
procedure SetupNonperiodicIRR;
procedure SetupNonperiodicNPV;
procedure SetupDecliningBalance;
procedure SetupVariableDecliningBalance;
procedure SetupDollarToDecimal;
procedure SetupDollarToFraction;
procedure SetupDollarToDecimalText;
procedure SetupDollarToFractionStr;
procedure SetupRoundToDecimal;
procedure SetupIsCardValid;
procedure SetupNetPresentValue;
procedure SetupFutureValue;
procedure SetupPresentValue;
procedure SetupBondPrice;
procedure SetupPayment;
procedure SetupInternalRateOfReturn;
procedure ExtEditExit(Sender: TObject);
procedure IntEditExit(Sender: TObject);
procedure DisableFields;
procedure FunctionsClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure GoBtnClick(Sender: TObject);
procedure FT(F : TWinControl; T: Integer; S: string);
procedure DateEditExit(Sender: TObject);
procedure VAEditExit(Sender: TObject);
procedure DAEditExit(Sender: TObject);
procedure FreqEditExit(Sender: TObject);
procedure BasEditExit(Sender: TObject);
procedure TimEditExit(Sender: TObject);
procedure StrEditExit(Sender: TObject);
procedure VAEditEnter(Sender: TObject);
procedure DAEditEnter(Sender: TObject);
procedure BoolEditExit(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
FinCalForm: TFinCalForm;
implementation
{$R *.lfm}
var
ExtVar : array[1..5] of Extended;
IntVar : array[1..5] of Integer;
DateVar : array[1..5] of TStDate;
FreqVar : TStFrequency;
BasVar : TStBasis;
TimVar : TStPaymentTime;
StrVar : String;
BoolVar : Boolean;
DateArray : array[0..29] of TStDate;
ValArray : array[0..29] of Double;
{------ Function parameters ------}
procedure TFinCalForm.FT(F : TWinControl; T: Integer; S: string);
begin
F.Enabled := true;
TEdit(F).Color := clYellow;
F.TabOrder := T;
F.Hint := S;
F.ShowHint := true;
end;
procedure TFinCalForm.SetupAccruedInterestPeriodic;
begin
FT(D1Edit, 1, 'Issue');
FT(D2Edit, 2, 'Settlement');
FT(D3Edit, 3, 'Maturity');
FT(E1Edit, 4, 'Rate');
FT(E2Edit, 5, 'Par');
FT(FreqEdit, 6, 'Frequency');
FT(BasEdit, 7, 'Basis');
end;
procedure TFinCalForm.SetupAccruedInterestMaturity;
begin
FT(D1Edit, 1, 'Issue');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Rate');
FT(E2Edit, 4, 'Par');
FT(BasEdit, 5, 'Basis');
end;
procedure TFinCalForm.SetupCumulativeInterest;
begin
FT(E1Edit, 1, 'Rate');
FT(I1Edit, 2, 'NPeriods');
FT(E2Edit, 3, 'Present Value');
FT(I2Edit, 4, 'Start Period');
FT(I3Edit, 5, 'End Period');
FT(FreqEdit, 6, 'Frequency');
FT(TimEdit, 7, 'Timing');
end;
procedure TFinCalForm.SetupCumulativePrincipal;
begin
SetupCumulativeInterest;
end;
procedure TFinCalForm.SetupDiscountRate;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Price');
FT(E2Edit, 4, 'Redemption');
FT(BasEdit, 5, 'Basis');
end;
procedure TFinCalForm.SetupEffectiveInterestRate;
begin
FT(E1Edit, 1, 'Nominal Rate');
FT(FreqEdit, 2, 'Frequency');
end;
procedure TFinCalForm.SetupNominalInterestRate;
begin
FT(E1Edit, 1, 'Effective Rate');
FT(FreqEdit, 2, 'Frequency');
end;
procedure TFinCalForm.SetupInterestRate;
begin
FT(I1Edit, 1, 'NPeriods');
FT(E1Edit, 2, 'Payment');
FT(E2Edit, 3, 'Present Value');
FT(E3Edit, 4, 'Future Value');
FT(FreqEdit, 5, 'Frequency');
FT(TimEdit, 6, 'Timing');
FT(E4Edit, 7, 'Guess');
end;
procedure TFinCalForm.SetupReceivedAtMaturity;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Investment');
FT(E2Edit, 4, 'Discount');
FT(BasEdit, 5, 'Basis');
end;
procedure TFinCalForm.SetupYieldPeriodic;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Rate');
FT(E2Edit, 4, 'Price');
FT(E3Edit, 5, 'Redemption');
FT(FreqEdit, 6, 'Frequency');
FT(BasEdit, 7, 'Basis');
end;
procedure TFinCalForm.SetupYieldDiscounted;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Price');
FT(E2Edit, 4, 'Redemption');
FT(BasEdit, 5, 'Basis');
end;
procedure TFinCalForm.SetupYieldMaturity;
begin
FT(D1Edit, 1, 'Issue');
FT(D2Edit, 2, 'Settlement');
FT(D3Edit, 3, 'Maturity');
FT(E1Edit, 4, 'Rate');
FT(E2Edit, 5, 'Price');
FT(BasEdit, 6, 'Basis');
end;
procedure TFinCalForm.SetupTBillEquivYield;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Discount');
end;
procedure TFinCalForm.SetupTBillPrice;
begin
SetupTBillEquivYield;
end;
procedure TFinCalForm.SetupTBillYield;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Price');
end;
procedure TFinCalForm.SetupBondDuration;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Rate');
FT(E2Edit, 4, 'Yield');
FT(FreqEdit, 5, 'Frequency');
FT(BasEdit, 6, 'Basis');
end;
procedure TFinCalForm.SetupModifiedDuration;
begin
SetupBondDuration;
end;
procedure TFinCalForm.SetupFutureValueSCHEDULE;
begin
FT(E1Edit, 1, 'Principal');
FT(VAEdit, 2, 'Schedule');
FT(I1Edit, 3, 'NRates');
end;
procedure TFinCalForm.SetupModifiedIRR;
begin
FT(VAEdit, 1, 'Values');
FT(I1Edit, 2, 'NValues');
FT(E1Edit, 3, 'Finance Rate');
FT(E2Edit, 4, 'Reinvest Rate');
end;
procedure TFinCalForm.SetupNonperiodicIRR;
begin
FT(I1Edit, 1, 'NValues');
FT(VAEdit, 2, 'Values');
FT(DAEdit, 3, 'Dates');
FT(E1Edit, 4, 'Guess');
end;
procedure TFinCalForm.SetupNonperiodicNPV;
begin
FT(I1Edit, 1, 'NValues');
FT(E1Edit, 2, 'Rate');
FT(VAEdit, 3, 'Values');
FT(DAEdit, 4, 'Dates');
end;
procedure TFinCalForm.SetupDecliningBalance;
begin
FT(E1Edit, 1, 'Cost');
FT(E2Edit, 2, 'Salvage');
FT(I1Edit, 3, 'Life');
FT(I2Edit, 4, 'Period');
FT(I3Edit, 5, 'Month');
end;
procedure TFinCalForm.SetupVariableDecliningBalance;
begin
FT(E1Edit, 1, 'Cost');
FT(E2Edit, 2, 'Salvage');
FT(I1Edit, 3, 'Life');
FT(E3Edit, 4, 'Start');
FT(E4Edit, 5, 'End');
FT(E5Edit, 6, 'Factor');
FT(BoolEdit, 7, 'No Switch');
end;
procedure TFinCalForm.SetupDollarToDecimal;
begin
FT(E1Edit, 1, 'Fractional Dollar');
FT(I1Edit, 2, 'Fraction');
end;
procedure TFinCalForm.SetupDollarToFraction;
begin
FT(E1Edit, 1, 'Decimal Dollar');
FT(I1Edit, 2, 'Fraction');
end;
procedure TFinCalForm.SetupDollarToDecimalText;
begin
FT(E1Edit, 1, 'Decimal Dollar');
end;
procedure TFinCalForm.SetupDollarToFractionStr;
begin
FT(E1Edit, 1, 'Fractional Dollar');
FT(I1Edit, 2, 'Fraction');
end;
procedure TFinCalForm.SetupRoundToDecimal;
begin
FT(E1Edit, 1, 'Value');
FT(I1Edit, 2, 'Places');
FT(BoolEdit, 3, 'Bankers');
end;
procedure TFinCalForm.SetupIsCardValid;
begin
FT(StrEdit, 1, 'Card Number');
end;
procedure TFinCalForm.SetupNetPresentValue;
begin
FT(E1Edit, 1, 'Rate');
FT(I1Edit, 2, 'NValues');
FT(VAEdit, 3, 'Values');
end;
procedure TFinCalForm.SetupFutureValue;
begin
FT(E1Edit, 1, 'Rate');
FT(I1Edit, 2, 'NPeriods');
FT(E2Edit, 3, 'Payment');
FT(E3Edit, 4, 'Present Value');
FT(FreqEdit, 5, 'Frequency');
FT(TimEdit, 6, 'Timing');
end;
procedure TFinCalForm.SetupPresentValue;
begin
FT(E1Edit, 1, 'Rate');
FT(I1Edit, 2, 'NPeriods');
FT(E2Edit, 3, 'Payment');
FT(E3Edit, 4, 'Future Value');
FT(FreqEdit, 5, 'Frequency');
FT(TimEdit, 6, 'Timing');
end;
procedure TFinCalForm.SetupBondPrice;
begin
FT(D1Edit, 1, 'Settlement');
FT(D2Edit, 2, 'Maturity');
FT(E1Edit, 3, 'Rate');
FT(E2Edit, 4, 'Yield');
FT(E3Edit, 5, 'Redemption');
FT(FreqEdit, 6, 'Frequency');
FT(BasEdit, 7, 'Basis');
end;
procedure TFinCalForm.SetupPayment;
begin
FT(E1Edit, 1, 'Rate');
FT(I1Edit, 2, 'NPeriods');
FT(E2Edit, 3, 'Present Value');
FT(E3Edit, 4, 'Future Value');
FT(FreqEdit, 5, 'Frequency');
FT(TimEdit, 6, 'Timing');
end;
procedure TFinCalForm.SetupInternalRateOfReturn;
begin
FT(I1Edit, 1, 'NValues');
FT(VAEdit, 2, 'Values');
FT(E1Edit, 3, 'Guess');
end;
{------- Function selection -------}
procedure TFinCalForm.GoBtnClick(Sender: TObject);
var
FR : Extended;
SR : String;
begin
FR := 0;
SR := '';
case Functions.ItemIndex of
0 : FR := AccruedInterestMaturity(DateVar[1], DateVar[2], ExtVar[1],
ExtVar[2], BasVar);
1 : FR := AccruedInterestPeriodic(DateVar[1], DateVar[2], DateVar[3],
ExtVar[1], ExtVar[2], FreqVar, BasVar);
2 : FR := BondDuration(DateVar[1], DateVar[2], ExtVar[1], ExtVar[2],
FreqVar, BasVar);
3 : FR := BondPrice(DateVar[1], DateVar[2], ExtVar[1], ExtVar[2],
ExtVar[3], FreqVar, BasVar);
4 : FR := CumulativeInterest(ExtVar[1], IntVar[1], ExtVar[2], IntVar[2],
IntVar[3], FreqVar, TimVar);
5 : FR := CumulativePrincipal(ExtVar[1], IntVar[1], ExtVar[2], IntVar[2],
IntVar[3], FreqVar, TimVar);
6 : FR := DecliningBalance(ExtVar[1], ExtVar[2], IntVar[1], IntVar[2],
IntVar[3]);
7 : FR := DiscountRate(DateVar[1], DateVar[2], ExtVar[1], ExtVar[2],
BasVar);
8 : FR := DollarToDecimal(ExtVar[1], IntVar[1]);
9 : SR := DollarToDecimalText(ExtVar[1]);
10 : FR := DollarToFraction(ExtVar[1], IntVar[1]);
11 : SR := DollarToFractionStr(ExtVar[1], IntVar[1]);
12 : FR := EffectiveInterestRate(ExtVar[1], FreqVar);
13 : FR := FutureValue(ExtVar[1], IntVar[1], ExtVar[2], ExtVar[3],
FreqVar, TimVar);
14 : FR := FutureValueSchedule16(ExtVar[1], ValArray, IntVar[1]);
15 : FR := InterestRate(IntVar[1], ExtVar[1], ExtVar[2], ExtVar[3],
FreqVar, TimVar, ExtVar[4]);
16 : FR := InternalRateOfReturn16(ValArray, IntVar[1], ExtVar[1]);
17 : if IsCardValid(StrVar) then
SR := 'Valid card number'
else
SR := 'Invalid card number';
18 : FR := ModifiedDuration(DateVar[1], DateVar[2], ExtVar[1],
ExtVar[2], FreqVar, BasVar);
19 : FR := ModifiedIRR16(ValArray, IntVar[1], ExtVar[1], ExtVar[2]);
20 : FR := NetPresentValue16(ExtVar[1], ValArray, IntVar[1]);
21 : FR := NominalInterestRate(ExtVar[1], FreqVar);
22 : FR := NonPeriodicIRR16(ValArray, DateArray, IntVar[1], ExtVar[1]);
23 : FR := NonPeriodicNPV16(ExtVar[1], ValArray, DateArray, IntVar[1]);
24 : FR := Payment(ExtVar[1], IntVar[1], ExtVar[2], ExtVar[3],
FreqVar, TimVar);
25 : FR := PresentValue(ExtVar[1], IntVar[1], ExtVar[2], ExtVar[3],
FreqVar, TimVar);
26 : FR := ReceivedAtMaturity(DateVar[1], DateVar[2], ExtVar[1],
ExtVar[2], BasVar);
27 : FR := RoundToDecimal(ExtVar[1], IntVar[1], BoolVar);
28 : FR := TBillEquivYield(DateVar[1], DateVar[2], ExtVar[1]);
29 : FR := TBillPrice(DateVar[1], DateVar[2], ExtVar[1]);
30 : FR := TBillYield(DateVar[1], DateVar[2], ExtVar[1]);
31 : FR := VariableDecliningBalance(ExtVar[1], ExtVar[2], IntVar[1],
ExtVar[3], ExtVar[4], ExtVar[5], BoolVar);
32 : FR := YieldPeriodic(DateVar[1], DateVar[2], ExtVar[1], ExtVar[2],
ExtVar[3], FreqVar, BasVar);
33 : FR := YieldDiscounted(DateVar[1], DateVar[2], ExtVar[1],
ExtVar[2], BasVar);
34 : FR := YieldMaturity(DateVar[1], DateVar[2], DateVar[3], ExtVar[1],
ExtVar[2], BasVar);
end;
FResult.Text := FloatToStr(FR);
SResult.Text := SR;
end;
procedure TFinCalForm.FunctionsClick(Sender: TObject);
begin
DisableFields;
case Functions.ItemIndex of
0 : SetupAccruedInterestMaturity;
1 : SetupAccruedInterestPeriodic;
2 : SetupBondDuration;
3 : SetupBondPrice;
4 : SetupCumulativeInterest;
5 : SetupCumulativePrincipal;
6 : SetupDecliningBalance;
7 : SetupDiscountRate;
8 : SetupDollarToDecimal;
9 : SetupDollarToDecimalText;
10 : SetupDollarToFraction;
11 : SetupDollarToFractionStr;
12 : SetupEffectiveInterestRate;
13 : SetupFutureValue;
14 : SetupFutureValueSchedule;
15 : SetupInterestRate;
16 : SetupInternalRateOfReturn;
17 : SetupIsCardValid;
18 : SetupModifiedDuration;
19 : SetupModifiedIRR;
20 : SetupNetPresentValue;
21 : SetupNominalInterestRate;
22 : SetupNonperiodicIRR;
23 : SetupNonperiodicNPV;
24 : SetupPayment;
25 : SetupPresentValue;
26 : SetupReceivedAtMaturity;
27 : SetupRoundToDecimal;
28 : SetupTBillEquivYield;
29 : SetupTBillPrice;
30 : SetupTBillYield;
31 : SetupVariableDecliningBalance;
32 : SetupYieldPeriodic;
33 : SetupYieldDiscounted;
34 : SetupYieldMaturity;
end;
end;
{------- Misc utilities and set up -------}
procedure TFinCalForm.DisableFields;
begin
E1Edit.Enabled := false;
E1Edit.Color := clwhite;
E2Edit.Enabled := false;
E2Edit.Color := clwhite;
E3Edit.Enabled := false;
E3Edit.Color := clwhite;
E4Edit.Enabled := false;
E4Edit.Color := clwhite;
E5Edit.Enabled := false;
E5Edit.Color := clwhite;
I1Edit.Enabled := false;
I1Edit.Color := clwhite;
I2Edit.Enabled := false;
I2Edit.Color := clwhite;
I3Edit.Enabled := false;
I3Edit.Color := clwhite;
I4Edit.Enabled := false;
I4Edit.Color := clwhite;
I5Edit.Enabled := false;
I5Edit.Color := clwhite;
D1Edit.Enabled := false;
D1Edit.Color := clwhite;
D2Edit.Enabled := false;
D2Edit.Color := clwhite;
D3Edit.Enabled := false;
D3Edit.Color := clwhite;
D4Edit.Enabled := false;
D4Edit.Color := clwhite;
D5Edit.Enabled := false;
D5Edit.Color := clwhite;
DAEdit.Enabled := false;
DAEdit.Color := clwhite;
VAEdit.Enabled := false;
VAEdit.Color := clwhite;
StrEdit.Enabled := false;
StrEdit.Color := clwhite;
TimEdit.Enabled := False;
TimEdit.Color := clWhite;
BasEdit.Enabled := False;
BasEdit.Color := clWhite;
FreqEdit.Enabled := False;
FreqEdit.Color := clWhite;
BoolEdit.Enabled := false;
BoolEdit.Color := clWhite;
end;
procedure TFinCalForm.ExtEditExit(Sender: TObject);
begin
with (Sender as TEdit) do
ExtVar[Tag] := StrToFloat(Text);
end;
procedure TFinCalForm.IntEditExit(Sender: TObject);
begin
with (Sender as TEdit) do
IntVar[Tag] := StrToInt(Text);
end;
procedure TFinCalForm.DateEditExit(Sender: TObject);
begin
with (Sender as TEdit) do
DateVar[Tag] := DateStringToStDate('mm/dd/yy', Text, 1920);
end;
procedure TFinCalForm.StrEditExit(Sender: TObject);
begin
StrVar := TEdit(Sender).Text;
end;
procedure TFinCalForm.DAEditEnter(Sender: TObject);
begin
DAEdit.Row := 0;
DAEdit.Col := 0;
end;
procedure TFinCalForm.DAEditExit(Sender: TObject);
var
I : Integer;
begin
for I := 0 to IntVar[1] - 1 do
DateArray[I] := DateStringToStDate('mm/dd/yy', DAEdit.Cells[0,I], 1950);
end;
procedure TFinCalForm.VAEditEnter(Sender: TObject);
begin
VAEdit.Row := 0;
VAEdit.Col := 0;
end;
procedure TFinCalForm.VAEditExit(Sender: TObject);
var
I : Integer;
begin
for I := 0 to IntVar[1] - 1 do
ValArray[I] := StrToFloat(VAEdit.Cells[0,I]);
end;
procedure TFinCalForm.FreqEditExit(Sender: TObject);
begin
case FreqEdit.ItemIndex of
0: FreqVar := fqAnnual;
1: FreqVar := fqSemiAnnual;
2: FreqVar := fqQuarterly;
3: FreqVar := fqMonthly;
end;
end;
procedure TFinCalForm.BasEditExit(Sender: TObject);
begin
case BasEdit.ItemIndex of
0: BasVar := BasisNASD;
1: BasVar := BasisActAct;
2: BasVar := BasisAct360;
3: BasVar := BasisAct365;
4: BasVar := BasisEur30360;
end;
end;
procedure TFinCalForm.TimEditExit(Sender: TObject);
begin
case TimEdit.ItemIndex of
0: TimVar := ptEndOfPeriod;
1: TimVar := ptStartOfPeriod;
end;
end;
procedure TFinCalForm.BoolEditExit(Sender: TObject);
begin
BoolVar := BoolEdit.Checked;
end;
procedure TFinCalForm.FormCreate(Sender: TObject);
var
I : Integer;
begin
for I := 1 to 5 do begin
ExtVar[I] := 0;
DateVar[I] := CurrentDate;
IntVar[I] := 0;
end;
E1Edit.Text := FloatToStr(ExtVar[1]);
E2Edit.Text := FloatToStr(ExtVar[2]);
E3Edit.Text := FloatToStr(ExtVar[3]);
E4Edit.Text := FloatToStr(ExtVar[4]);
E5Edit.Text := FloatToStr(ExtVar[5]);
I1Edit.Text := IntToStr(IntVar[1]);
I2Edit.Text := IntToStr(IntVar[2]);
I3Edit.Text := IntToStr(IntVar[3]);
I4Edit.Text := IntToStr(IntVar[4]);
I5Edit.Text := IntToStr(IntVar[5]);
D1Edit.Text := DateToStr(DateVar[1]);
D2Edit.Text := DateToStr(DateVar[2]);
D3Edit.Text := DateToStr(DateVar[3]);
D4Edit.Text := DateToStr(DateVar[4]);
D5Edit.Text := DateToStr(DateVar[5]);
DisableFields;
for I := 0 to 29 do begin
ValArray[I] := 0;
DateArray[I] := CurrentDate;
end;
TimEdit.ItemIndex := 0;
TimVar := ptEndOfPeriod;
BasEdit.ItemIndex := 0;
BasVar := BasisNASD;
FreqEdit.ItemIndex := 0;
FreqVar := fqAnnual;
BoolEdit.Checked := false;
BoolVar := false;
Application.HintPause := 250;
Application.HintColor := clAqua;
end;
procedure TFinCalForm.BitBtn1Click(Sender: TObject);
begin
Close;
end;
end.

83
components/systools/examples/financial_calculator/fincl.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="fincl"/>
<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="fincl.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Fincal"/>
</Unit0>
<Unit1>
<Filename Value="fincalu.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="FinCalForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Fincalu"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="fincl"/>
</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>

42
components/systools/examples/financial_calculator/fincl.lpr Normal file
View File

@ -0,0 +1,42 @@
(* ***** 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 ***** *)
program Fincal;
uses
Interfaces,
Forms, lclversion,
fincalu in 'fincalu.pas' {FinCalForm};
{$R *.res}
begin
{$IF lcl_fullversion >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TFinCalForm, FinCalForm);
Application.Run;
end.

82
components/systools/examples/html/ex2html.lpi Normal file
View File

@ -0,0 +1,82 @@
<?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="ex2html"/>
<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="ex2html.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="EX2HTML"/>
</Unit0>
<Unit1>
<Filename Value="ex2htmlu.pas"/>
<IsPartOfProject Value="True"/>
<HasResources Value="True"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="ex2html"/>
</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>

38
components/systools/examples/html/ex2html.lpr Normal file
View File

@ -0,0 +1,38 @@
(* ***** 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 ***** *)
program EX2HTML;
uses
Forms, Interfaces,
ex2htmlu in 'ex2htmlu.pas' {Form1};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

184
components/systools/examples/html/ex2htmlu.lfm Normal file
View File

@ -0,0 +1,184 @@
object Form1: TForm1
Left = 384
Height = 184
Top = 318
Width = 221
BorderStyle = bsDialog
Caption = 'EXTOHTML'
ClientHeight = 184
ClientWidth = 221
Color = clBtnFace
Font.Color = clBlack
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 10
Height = 15
Top = 12
Width = 49
Caption = 'Input File'
ParentColor = False
end
object Label2: TLabel
Left = 10
Height = 15
Top = 59
Width = 59
Caption = 'Output File'
ParentColor = False
end
object SpeedButton1: TSpeedButton
Left = 184
Height = 25
Top = 28
Width = 25
OnClick = GetFileClick
end
object SpeedButton2: TSpeedButton
Left = 183
Height = 25
Top = 75
Width = 25
OnClick = GetFileClick
end
object Label3: TLabel
Left = 10
Height = 15
Top = 115
Width = 41
Caption = 'Waiting'
ParentColor = False
end
object Button1: TButton
Left = 66
Height = 25
Top = 147
Width = 75
Caption = 'Convert'
OnClick = Button1Click
TabOrder = 2
end
object Edit1: TEdit
Left = 10
Height = 23
Top = 29
Width = 169
TabOrder = 0
Text = '..\..\source\run/sttohtml.pas'
end
object Edit2: TEdit
Left = 10
Height = 23
Top = 76
Width = 168
TabOrder = 1
Text = 'out.htm'
end
object StFileToHTML1: TStFileToHTML
CommentMarkers.Strings = (
'//=;<font color=#FF0000><i>;</i></font>'
'(*=*);<font color=#FF0000><i>;</i></font>'
'/*=*/;<font color=#FF0000><i>;</i></font>'
'{=};<font color=#FF0000><i>;</i></font>'
)
EmbeddedHTML.Strings = (
'"=&quot;'
'&=&amp;'
'<=&lt;'
'>=&gt;'
'¡=&iexcl;'
'¢=&cent;'
'£=&pound;'
'©=&copy;'
'®=&reg;'
'±=&plusmn;'
'¼=&frac14;'
'½=&frac12;'
'¾=&frac34;'
'÷=&divide;'
)
Keywords.Strings = (
'and=<B>;</B>'
'array=<B>;</B>'
'as=<B>;</B>'
'asm=<B>;</B>'
'begin=<B>;</B>'
'case=<B>;</B>'
'class=<B>;</B>'
'const=<B>;</B>'
'constructor=<B>;</B>'
'destructor=<B>;</B>'
'dispinterface=<B>;</B>'
'div=<B>;</B>'
'do=<B>;</B>'
'downto=<B>;</B>'
'else=<B>;</B>'
'end=<B>;</B>'
'except=<B>;</B>'
'exports=<B>;</B>'
'file=<B>;</B>'
'finalization=<B>;</B>'
'finally=<B>;</B>'
'for=<B>;</B>'
'function=<B>;</B>'
'goto=<B>;</B>'
'if=<B>;</B>'
'implementation=<B>;</B>'
'in=<B>;</B>'
'inherited=<B>;</B>'
'initialization=<B>;</B>'
'inline=<B>;</B>'
'interface=<B>;</B>'
'is=<B>;</B>'
'label=<B>;</B>'
'library=<B>;</B>'
'mod=<B>;</B>'
'nil=<B>;</B>'
'not=<B>;</B>'
'object=<B>;</B>'
'of=<B>;</B>'
'or=<B>;</B>'
'out=<B>;</B>'
'packed=<B>;</B>'
'procedure=<B>;</B>'
'program=<B>;</B>'
'property=<B>;</B>'
'protected=<B>;</B>'
'public=<B>;</B>'
'raise=<B>;</B>'
'record=<B>;</B>'
'repeat=<B>;</B>'
'resourcestring=<B>;</B>'
'set=<B>;</B>'
'shl=<B>;</B>'
'shr=<B>;</B>'
'string=<B>;</B>'
'then=<B>;</B>'
'thread=<B>;</B>'
'var=<B>;</B>'
'to=<B>;</B>'
'try=<B>;</B>'
'type=<B>;</B>'
'unit=<B>;</B>'
'until=<B>;</B>'
'uses=<B>;</B>'
'var=<B>;</B>'
'while=<B>;</B>'
'with=<B>;</B>'
)
OnProgress = StFileToHTML1Progress
StringMarkers.Strings = (
'"=";<font color=#0000FF>;</font>'
'''='';<font color=#0000FF>;</font>'
)
WordDelimiters = ',; .()'
left = 133
top = 1
end
object OpenDialog1: TOpenDialog
Filter = 'Pascal files (*.pas)|*.pas|C++ files (*.cpp)|*.cpp|All files (*.*)|*.*'
Options = [ofOverwritePrompt, ofPathMustExist]
left = 97
top = 65535
end
end

99
components/systools/examples/html/ex2htmlu.pas Normal file
View File

@ -0,0 +1,99 @@
(* ***** 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 ***** *)
unit ex2htmlu;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons,
StBase, StToHTML;
type
TForm1 = class(TForm)
Button1: TButton;
StFileToHTML1: TStFileToHTML;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
SpeedButton1: TSpeedButton;
SpeedButton2: TSpeedButton;
Label3: TLabel;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
procedure GetFileClick(Sender: TObject);
procedure StFileToHTML1Progress(Sender: TObject; Percent: Word);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if (not FileExists(Edit1.Text)) then begin
ShowMessage('Input file does not exist');
Exit;
end;
StFileToHTML1.InFileName := Edit1.Text;
StFileToHTML1.OutFileName := Edit2.Text;
StFileToHTML1.Execute;
Label1.Caption := 'Waiting';
ShowMessage('Done');
end;
procedure TForm1.GetFileClick(Sender: TObject);
begin
if (OpenDialog1.Execute) then begin
if (Sender = SpeedButton1) then
Edit1.Text := OpenDialog1.FileName
else if (Sender = SpeedButton2) then
Edit2.Text := OpenDialog1.FileName;
end;
end;
procedure TForm1.StFileToHTML1Progress(Sender: TObject; Percent: Word);
begin
Label1.Caption := 'Completed: ' + IntToStr(Percent) + '%';
end;
end.

369
components/systools/examples/money_calculator/moneycal0.lfm Normal file
View File

@ -0,0 +1,369 @@
object MoneyCalcDlg: TMoneyCalcDlg
Left = 191
Height = 283
Top = 116
Width = 756
BorderStyle = bsDialog
Caption = 'Money Calculator'
ClientHeight = 283
ClientWidth = 756
Color = clBtnFace
Font.Color = clWindowText
OnCreate = FormCreate
OnDestroy = FormDestroy
OnKeyPress = FormKeyPress
LCLVersion = '1.9.0.0'
object GroupBox1: TGroupBox
Left = 4
Height = 268
Top = 4
Width = 209
Caption = ' Calculator '
ClientHeight = 248
ClientWidth = 205
TabOrder = 0
TabStop = True
object ZeroBtn: TBitBtn
Left = 8
Height = 28
Top = 214
Width = 35
Caption = '0'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 1
TabStop = False
end
object DecKey: TBitBtn
Left = 86
Height = 28
Top = 214
Width = 35
Caption = '.'
Font.Color = clBlue
OnClick = DecKeyClick
ParentFont = False
TabOrder = 4
TabStop = False
end
object ThreeKey: TBitBtn
Tag = 3
Left = 86
Height = 28
Top = 181
Width = 35
Caption = '3'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 7
TabStop = False
end
object OneKey: TBitBtn
Tag = 1
Left = 8
Height = 28
Top = 181
Width = 35
Caption = '1'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 2
TabStop = False
end
object TwoKey: TBitBtn
Tag = 2
Left = 47
Height = 28
Top = 181
Width = 35
Caption = '2'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 3
TabStop = False
end
object SixKey: TBitBtn
Tag = 6
Left = 86
Height = 28
Top = 149
Width = 35
Caption = '6'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 10
TabStop = False
end
object FourKey: TBitBtn
Tag = 4
Left = 8
Height = 28
Top = 149
Width = 35
Caption = '4'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 5
TabStop = False
end
object FiveKey: TBitBtn
Tag = 5
Left = 47
Height = 28
Top = 149
Width = 35
Caption = '5'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 6
TabStop = False
end
object NineKey: TBitBtn
Tag = 9
Left = 86
Height = 28
Top = 116
Width = 35
Caption = '9'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 16
TabStop = False
end
object SevenKey: TBitBtn
Tag = 7
Left = 8
Height = 28
Top = 116
Width = 35
Caption = '7'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 8
TabStop = False
end
object EightKey: TBitBtn
Tag = 8
Left = 47
Height = 28
Top = 116
Width = 35
Caption = '8'
Font.Color = clBlue
OnClick = NumBtnClick
ParentFont = False
TabOrder = 9
TabStop = False
end
object AddBtn: TBitBtn
Left = 125
Height = 28
Top = 214
Width = 35
Caption = '+'
Font.Color = clRed
OnClick = AddBtnClick
ParentFont = False
TabOrder = 12
TabStop = False
end
object SubBtn: TBitBtn
Left = 125
Height = 28
Top = 181
Width = 35
Caption = '-'
Font.Color = clRed
OnClick = SubBtnClick
ParentFont = False
TabOrder = 13
TabStop = False
end
object MulBtn: TBitBtn
Left = 125
Height = 28
Top = 149
Width = 35
Caption = '*'
Font.Color = clRed
OnClick = MulBtnClick
ParentFont = False
TabOrder = 14
TabStop = False
end
object DivBtn: TBitBtn
Left = 125
Height = 28
Top = 116
Width = 35
Caption = '/'
Font.Color = clRed
OnClick = DivBtnClick
ParentFont = False
TabOrder = 15
TabStop = False
end
object PlusMinusBtn: TBitBtn
Left = 47
Height = 28
Top = 214
Width = 35
Caption = '+/-'
Font.Color = clBlue
OnClick = PlusMinusBtnClick
ParentFont = False
TabOrder = 11
TabStop = False
end
object ClearBtn: TBitBtn
Left = 147
Height = 28
Top = 80
Width = 52
Caption = 'C'
Font.Color = clRed
OnClick = ClearBtnClick
ParentFont = False
TabOrder = 19
TabStop = False
end
object EqualBtn: TBitBtn
Left = 164
Height = 126
Top = 116
Width = 35
Caption = '='
Font.Color = clRed
OnClick = EqualBtnClick
ParentFont = False
TabOrder = 0
TabStop = False
end
object ClearEntryBtn: TBitBtn
Left = 86
Height = 28
Top = 80
Width = 56
Caption = 'CE'
Font.Color = clRed
OnClick = ClearEntryBtnClick
ParentFont = False
TabOrder = 18
TabStop = False
end
object Memo1: TMemo
Left = 8
Height = 73
Top = 0
Width = 191
Alignment = taRightJustify
MaxLength = 40
OnKeyDown = Memo1KeyDown
PopupMenu = PopupMenu1
ReadOnly = True
TabOrder = 20
WantReturns = False
WantTabs = True
WordWrap = False
end
object BSBtn: TBitBtn
Left = 8
Height = 28
Top = 80
Width = 74
Caption = 'Backspace'
Font.Color = clRed
OnClick = BSBtnClick
ParentFont = False
TabOrder = 17
TabStop = False
end
end
object GroupBox2: TGroupBox
Left = 220
Height = 268
Top = 4
Width = 524
Caption = ' Conversions '
ClientHeight = 248
ClientWidth = 520
TabOrder = 1
TabStop = True
object Label1: TLabel
Left = 20
Height = 15
Top = 25
Width = 51
Caption = 'Currency:'
ParentColor = False
end
object ComboBox1: TComboBox
Left = 96
Height = 23
Top = 21
Width = 85
DropDownCount = 32
ItemHeight = 15
OnChange = ComboBox1Change
Sorted = True
TabOrder = 0
end
object ComboBox2: TComboBox
Left = 368
Height = 23
Top = 21
Width = 85
DropDownCount = 32
ItemHeight = 15
OnChange = ComboBox2Change
Sorted = True
TabOrder = 3
end
object ConvertBtn: TBitBtn
Left = 248
Height = 25
Top = 20
Width = 113
Caption = 'Convert To'
OnClick = ConvertBtnClick
TabOrder = 2
end
object ListBox1: TListBox
Left = 20
Height = 188
Top = 52
Width = 204
ItemHeight = 0
TabOrder = 1
end
object ListBox2: TListBox
Left = 248
Height = 188
Top = 52
Width = 256
ItemHeight = 0
TabOrder = 4
end
end
object PopupMenu1: TPopupMenu
left = 232
top = 184
object Copy1: TMenuItem
Caption = 'Copy'
OnClick = Copy1Click
end
object Paste1: TMenuItem
Caption = 'Paste'
OnClick = Paste1Click
end
end
end

88
components/systools/examples/money_calculator/moneycal0.lrs Normal file
View File

@ -0,0 +1,88 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TMoneyCalcDlg','FORMDATA',[
'TPF0'#13'TMoneyCalcDlg'#12'MoneyCalcDlg'#4'Left'#3#191#0#6'Height'#3#31#1#3
+'Top'#2't'#5'Width'#3#20#2#11'BorderStyle'#7#8'bsDialog'#7'Caption'#6#16'Mon'
+'ey Calculator'#12'ClientHeight'#3#31#1#11'ClientWidth'#3#20#2#5'Color'#7#9
+'clBtnFace'#10'Font.Color'#7#12'clWindowText'#8'OnCreate'#7#10'FormCreate'#9
+'OnDestroy'#7#11'FormDestroy'#10'OnKeyPress'#7#12'FormKeyPress'#10'LCLVersio'
+'n'#6#7'1.9.0.0'#0#9'TGroupBox'#9'GroupBox1'#4'Left'#2#4#6'Height'#3#254#0#3
+'Top'#2#4#5'Width'#3#209#0#7'Caption'#6#12' Calculator '#12'ClientHeight'#3
+#234#0#11'ClientWidth'#3#205#0#8'TabOrder'#2#0#7'TabStop'#9#0#7'TBitBtn'#7'Z'
+'eroBtn'#4'Left'#2#10#6'Height'#2#28#3'Top'#3#190#0#5'Width'#2'#'#7'Caption'
+#6#1'0'#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'NumBtnClick'#10'ParentFon'
+'t'#8#8'TabOrder'#2#1#7'TabStop'#8#0#0#7'TBitBtn'#6'DecKey'#4'Left'#2'X'#6'H'
+'eight'#2#28#3'Top'#3#190#0#5'Width'#2'#'#7'Caption'#6#1'.'#10'Font.Color'#7
+#6'clBlue'#7'OnClick'#7#11'DecKeyClick'#10'ParentFont'#8#8'TabOrder'#2#4#7'T'
+'abStop'#8#0#0#7'TBitBtn'#8'ThreeKey'#3'Tag'#2#3#4'Left'#2'X'#6'Height'#2#28
+#3'Top'#3#157#0#5'Width'#2'#'#7'Caption'#6#1'3'#10'Font.Color'#7#6'clBlue'#7
+'OnClick'#7#11'NumBtnClick'#10'ParentFont'#8#8'TabOrder'#2#7#7'TabStop'#8#0#0
+#7'TBitBtn'#6'OneKey'#3'Tag'#2#1#4'Left'#2#10#6'Height'#2#28#3'Top'#3#157#0#5
+'Width'#2'#'#7'Caption'#6#1'1'#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'Nu'
+'mBtnClick'#10'ParentFont'#8#8'TabOrder'#2#2#7'TabStop'#8#0#0#7'TBitBtn'#6'T'
+'woKey'#3'Tag'#2#2#4'Left'#2'1'#6'Height'#2#28#3'Top'#3#157#0#5'Width'#2'#'#7
+'Caption'#6#1'2'#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'NumBtnClick'#10
+'ParentFont'#8#8'TabOrder'#2#3#7'TabStop'#8#0#0#7'TBitBtn'#6'SixKey'#3'Tag'#2
+#6#4'Left'#2'X'#6'Height'#2#28#3'Top'#2'}'#5'Width'#2'#'#7'Caption'#6#1'6'#10
+'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'NumBtnClick'#10'ParentFont'#8#8'Tab'
+'Order'#2#10#7'TabStop'#8#0#0#7'TBitBtn'#7'FourKey'#3'Tag'#2#4#4'Left'#2#10#6
+'Height'#2#28#3'Top'#2'}'#5'Width'#2'#'#7'Caption'#6#1'4'#10'Font.Color'#7#6
+'clBlue'#7'OnClick'#7#11'NumBtnClick'#10'ParentFont'#8#8'TabOrder'#2#5#7'Tab'
+'Stop'#8#0#0#7'TBitBtn'#7'FiveKey'#3'Tag'#2#5#4'Left'#2'1'#6'Height'#2#28#3
+'Top'#2'}'#5'Width'#2'#'#7'Caption'#6#1'5'#10'Font.Color'#7#6'clBlue'#7'OnCl'
+'ick'#7#11'NumBtnClick'#10'ParentFont'#8#8'TabOrder'#2#6#7'TabStop'#8#0#0#7
+'TBitBtn'#7'NineKey'#3'Tag'#2#9#4'Left'#2'X'#6'Height'#2#28#3'Top'#2'\'#5'Wi'
+'dth'#2'#'#7'Caption'#6#1'9'#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'NumB'
+'tnClick'#10'ParentFont'#8#8'TabOrder'#2#16#7'TabStop'#8#0#0#7'TBitBtn'#8'Se'
+'venKey'#3'Tag'#2#7#4'Left'#2#10#6'Height'#2#28#3'Top'#2'\'#5'Width'#2'#'#7
+'Caption'#6#1'7'#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'NumBtnClick'#10
+'ParentFont'#8#8'TabOrder'#2#8#7'TabStop'#8#0#0#7'TBitBtn'#8'EightKey'#3'Tag'
+#2#8#4'Left'#2'1'#6'Height'#2#28#3'Top'#2'\'#5'Width'#2'#'#7'Caption'#6#1'8'
+#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#11'NumBtnClick'#10'ParentFont'#8#8
+'TabOrder'#2#9#7'TabStop'#8#0#0#7'TBitBtn'#6'AddBtn'#4'Left'#2#127#6'Height'
+#2#28#3'Top'#3#190#0#5'Width'#2'#'#7'Caption'#6#1'+'#10'Font.Color'#7#5'clRe'
+'d'#7'OnClick'#7#11'AddBtnClick'#10'ParentFont'#8#8'TabOrder'#2#12#7'TabStop'
+#8#0#0#7'TBitBtn'#6'SubBtn'#4'Left'#2#127#6'Height'#2#28#3'Top'#3#157#0#5'Wi'
+'dth'#2'#'#7'Caption'#6#1'-'#10'Font.Color'#7#5'clRed'#7'OnClick'#7#11'SubBt'
+'nClick'#10'ParentFont'#8#8'TabOrder'#2#13#7'TabStop'#8#0#0#7'TBitBtn'#6'Mul'
+'Btn'#4'Left'#2#127#6'Height'#2#28#3'Top'#2'}'#5'Width'#2'#'#7'Caption'#6#1
+'*'#10'Font.Color'#7#5'clRed'#7'OnClick'#7#11'MulBtnClick'#10'ParentFont'#8#8
+'TabOrder'#2#14#7'TabStop'#8#0#0#7'TBitBtn'#6'DivBtn'#4'Left'#2#127#6'Height'
+#2#28#3'Top'#2'\'#5'Width'#2'#'#7'Caption'#6#1'/'#10'Font.Color'#7#5'clRed'#7
+'OnClick'#7#11'DivBtnClick'#10'ParentFont'#8#8'TabOrder'#2#15#7'TabStop'#8#0
+#0#7'TBitBtn'#12'PlusMinusBtn'#4'Left'#2'1'#6'Height'#2#28#3'Top'#3#190#0#5
+'Width'#2'#'#7'Caption'#6#3'+/-'#10'Font.Color'#7#6'clBlue'#7'OnClick'#7#17
+'PlusMinusBtnClick'#10'ParentFont'#8#8'TabOrder'#2#11#7'TabStop'#8#0#0#7'TBi'
+'tBtn'#8'ClearBtn'#4'Left'#3#149#0#6'Height'#2#28#3'Top'#2'8'#5'Width'#2'4'#7
+'Caption'#6#1'C'#10'Font.Color'#7#5'clRed'#7'OnClick'#7#13'ClearBtnClick'#10
+'ParentFont'#8#8'TabOrder'#2#19#7'TabStop'#8#0#0#7'TBitBtn'#8'EqualBtn'#4'Le'
+'ft'#3#166#0#6'Height'#2'~'#3'Top'#2'\'#5'Width'#2'#'#7'Caption'#6#1'='#10'F'
+'ont.Color'#7#5'clRed'#7'OnClick'#7#13'EqualBtnClick'#10'ParentFont'#8#8'Tab'
+'Order'#2#0#7'TabStop'#8#0#0#7'TBitBtn'#13'ClearEntryBtn'#4'Left'#2'X'#6'Hei'
+'ght'#2#28#3'Top'#2'8'#5'Width'#2'8'#7'Caption'#6#2'CE'#10'Font.Color'#7#5'c'
+'lRed'#7'OnClick'#7#18'ClearEntryBtnClick'#10'ParentFont'#8#8'TabOrder'#2#18
+#7'TabStop'#8#0#0#5'TMemo'#5'Memo1'#4'Left'#2#8#6'Height'#2#25#3'Top'#2#20#5
+'Width'#3#193#0#9'Alignment'#7#14'taRightJustify'#9'MaxLength'#2'('#9'OnKeyD'
+'own'#7#12'Memo1KeyDown'#9'PopupMenu'#7#10'PopupMenu1'#8'ReadOnly'#9#8'TabOr'
+'der'#2#20#11'WantReturns'#8#8'WantTabs'#9#8'WordWrap'#8#0#0#7'TBitBtn'#5'BS'
,'Btn'#4'Left'#2#10#6'Height'#2#28#3'Top'#2'8'#5'Width'#2'J'#7'Caption'#6#9'B'
+'ackspace'#10'Font.Color'#7#5'clRed'#7'OnClick'#7#10'BSBtnClick'#10'ParentFo'
+'nt'#8#8'TabOrder'#2#17#7'TabStop'#8#0#0#0#9'TGroupBox'#9'GroupBox2'#4'Left'
+#3#220#0#6'Height'#3#254#0#3'Top'#2#4#5'Width'#3'1'#1#7'Caption'#6#13' Conve'
+'rsions '#12'ClientHeight'#3#234#0#11'ClientWidth'#3'-'#1#8'TabOrder'#2#1#7
+'TabStop'#9#0#6'TLabel'#6'Label1'#4'Left'#2#20#6'Height'#2#15#3'Top'#2#24#5
+'Width'#2'3'#7'Caption'#6#9'Currency:'#11'ParentColor'#8#0#0#9'TComboBox'#9
+'ComboBox1'#4'Left'#2'`'#6'Height'#2#23#3'Top'#2#24#5'Width'#2'U'#10'ItemHei'
+'ght'#2#15#8'OnChange'#7#15'ComboBox1Change'#6'Sorted'#9#8'TabOrder'#2#0#0#0
+#9'TComboBox'#9'ComboBox2'#4'Left'#3#168#0#6'Height'#2#23#3'Top'#2'x'#5'Widt'
+'h'#2'U'#10'ItemHeight'#2#15#8'OnChange'#7#15'ComboBox2Change'#6'Sorted'#9#8
+'TabOrder'#2#3#0#0#7'TBitBtn'#10'ConvertBtn'#4'Left'#2'0'#6'Height'#2#25#3'T'
+'op'#2'x'#5'Width'#2'q'#7'Caption'#6#10'Convert To'#7'OnClick'#7#15'ConvertB'
+'tnClick'#8'TabOrder'#2#2#0#0#8'TListBox'#8'ListBox1'#4'Left'#2#20#6'Height'
+#2'='#3'Top'#2'4'#5'Width'#3#17#1#10'ItemHeight'#2#0#8'TabOrder'#2#1#0#0#8'T'
+'ListBox'#8'ListBox2'#4'Left'#2#20#6'Height'#2'E'#3'Top'#3#152#0#5'Width'#3
+#13#1#10'ItemHeight'#2#0#8'TabOrder'#2#4#0#0#0#10'TPopupMenu'#10'PopupMenu1'
+#4'left'#3#232#0#3'top'#3#184#0#0#9'TMenuItem'#5'Copy1'#7'Caption'#6#4'Copy'
+#7'OnClick'#7#10'Copy1Click'#0#0#9'TMenuItem'#6'Paste1'#7'Caption'#6#5'Paste'
+#7'OnClick'#7#11'Paste1Click'#0#0#0#0
]);

553
components/systools/examples/money_calculator/moneycal0.pas Normal file
View File

@ -0,0 +1,553 @@
(* ***** 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 moneycal0;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls, Menus, ClipBrd,
StStrL, StDecMth, StMoney;
const
DefaultCurrency = 'USD';
BaseFormCaption = 'Money Calculator';
type
MoneyCharSet = set of Char;
MoneyOperSet = set of Char;
type
TMoneyCalcDlg = class(TForm)
GroupBox1: TGroupBox;
ZeroBtn: TBitBtn;
DecKey: TBitBtn;
ThreeKey: TBitBtn;
OneKey: TBitBtn;
TwoKey: TBitBtn;
SixKey: TBitBtn;
FourKey: TBitBtn;
FiveKey: TBitBtn;
NineKey: TBitBtn;
SevenKey: TBitBtn;
EightKey: TBitBtn;
AddBtn: TBitBtn;
SubBtn: TBitBtn;
MulBtn: TBitBtn;
DivBtn: TBitBtn;
PlusMinusBtn: TBitBtn;
ClearBtn: TBitBtn;
EqualBtn: TBitBtn;
ClearEntryBtn: TBitBtn;
GroupBox2: TGroupBox;
Label1: TLabel;
ComboBox1: TComboBox;
ComboBox2: TComboBox;
ConvertBtn: TBitBtn;
ListBox1: TListBox;
ListBox2: TListBox;
Memo1: TMemo;
BSBtn: TBitBtn;
PopupMenu1: TPopupMenu;
Copy1: TMenuItem;
Paste1: TMenuItem;
procedure NumBtnClick(Sender: TObject);
procedure DecKeyClick(Sender: TObject);
procedure ClearBtnClick(Sender: TObject);
procedure ClearEntryBtnClick(Sender: TObject);
procedure AddBtnClick(Sender: TObject);
procedure SubBtnClick(Sender: TObject);
procedure MulBtnClick(Sender: TObject);
procedure DivBtnClick(Sender: TObject);
procedure PlusMinusBtnClick(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure EqualBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ConvertBtnClick(Sender: TObject);
procedure ComboBox2Change(Sender: TObject);
procedure Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure BSBtnClick(Sender: TObject);
procedure Copy1Click(Sender: TObject);
procedure Paste1Click(Sender: TObject);
private
procedure UpdateConversionCombo;
procedure UpdateCurrencyCombo;
procedure UpdateFormCaption;
procedure ShowExchangeData(const src, trg: string);
procedure ShowCurrencyData(const Name : string);
{ Private declarations }
public
MoneyChar : MoneyCharSet;
MoneyOper : MoneyOperSet;
PendOp : Char;
DFHold : Integer;
XBuffer : string[20];
ClearOnNext, Converting : Boolean;
BaseCurrency : string;
Currencies : TStCurrencyList;
Conversions : TStExchangeRateList;
procedure SendKeyPress(Sender : TObject; C : Char);
procedure DoRateUpdate(Sender: TObject; NewRate: TStDecimal;
var NewDate: TDateTime);
{ Public declarations }
end;
var
MoneyCalcDlg: TMoneyCalcDlg;
implementation
{$R *.lfm}
procedure TMoneyCalcDlg.UpdateFormCaption;
begin
if BaseCurrency <> '' then
Caption := BaseFormCaption + '-' + BaseCurrency
else
Caption := BaseFormCaption;
end;
procedure TMoneyCalcDlg.FormCreate(Sender: TObject);
begin
MoneyChar := ['0'..'9', FormatSettings.DecimalSeparator, '~'];
MoneyOper := ['+', '-', '/', '*'];
DecKey.Caption := FormatSettings.DecimalSeparator;
Memo1.Lines.Text := '0';
// Memo1.Lines[0] := '0';
PendOp := #0;
DFHold := 0;
XBuffer := '0';
ClearOnNext := False;
Currencies := TStCurrencyList.Create;
Currencies.LoadFromFile('..\..\source\run\stccy.dat');
UpdateCurrencyCombo;
ComboBox1.Text := DefaultCurrency;
ComboBox1.ItemIndex := ComboBox1.Items.IndexOf(ComboBox1.Text);
BaseCurrency := ComboBox1.Text;
ShowCurrencyData(ComboBox1.Text);
Conversions := TStExchangeRateList.Create;
Conversions.LoadFromFile('..\..\source\run\stccycnv.dat');
UpdateConversionCombo;
UpdateFormCaption;
end;
procedure TMoneyCalcDlg.FormDestroy(Sender: TObject);
begin
Currencies.Free;
Conversions.Free;
end;
procedure TMoneyCalcDlg.SendKeyPress(Sender : TObject; C : Char);
var
KP : Char;
begin
KP := C;
FormKeyPress(Sender,KP);
end;
procedure TMoneyCalcDlg.NumBtnClick(Sender: TObject);
var
C : Char;
begin
C := IntToStr((Sender as TBitBtn).Tag)[1];
SendKeyPress(Sender, C);
end;
procedure TMoneyCalcDlg.DecKeyClick(Sender: TObject);
begin
SendKeyPress(Sender, SysUtils.DecimalSeparator);
end;
procedure TMoneyCalcDlg.ClearBtnClick(Sender: TObject);
begin
XBuffer := '0.';
Memo1.Lines[0] := '0.';
PendOp := #0;
ClearOnNext := True;
end;
procedure TMoneyCalcDlg.ClearEntryBtnClick(Sender: TObject);
begin
Memo1.Lines[0] := '0.';
ClearOnNext := True;
end;
procedure TMoneyCalcDlg.AddBtnClick(Sender: TObject);
begin
SendKeyPress(Sender,'+');
end;
procedure TMoneyCalcDlg.SubBtnClick(Sender: TObject);
begin
SendKeyPress(Sender,'-');
end;
procedure TMoneyCalcDlg.MulBtnClick(Sender: TObject);
begin
SendKeyPress(Sender,'*');
end;
procedure TMoneyCalcDlg.DivBtnClick(Sender: TObject);
begin
SendKeyPress(Sender,'/');
end;
procedure TMoneyCalcDlg.PlusMinusBtnClick(Sender: TObject);
begin
SendKeyPress(Sender,'~');
end;
procedure TMoneyCalcDlg.FormKeyPress(Sender: TObject; var Key: Char);
var
HldOp : Char;
L : Integer;
Money1 : TStMoney;
S : string[21];
begin
Money1 := TStMoney.Create;
if Memo1.Lines[0] = '0' then
Memo1.Lines[0] := '';
try
if Key = #13 then begin
if XBuffer = '0' then begin
XBuffer := Memo1.Lines[0];
end
else begin
EqualBtnClick(Sender);
XBuffer := '0';
end;
Key := #0;
ClearOnNext := True;
end;
if Key in MoneyChar then begin
if (Length(Memo1.Lines[0]) = 0) and (Key = SysUtils.DecimalSeparator) then
Memo1.Lines[0] := '0';
if (Key = '~') then begin
S := Memo1.Lines[0];
if (S[1] <> '-') then
Insert('-',S,1)
else
Delete(S,1,1);
Memo1.Lines[0] := S;
Money1.Amount.AsString := S;
Key := #0;
end else begin
if ClearOnNext then begin
Memo1.Lines[0] := '';
ClearOnNext := False;
end;
end;
end;
if Key in MoneyOper then begin
if not (Key in ['s', 'e', 'l']) then begin
if Memo1.Lines[0] = '' then
Memo1.Lines[0] := '0';
if (XBuffer <> '0') then
EqualBtnClick(Sender);
XBuffer := Memo1.Lines[0];
Money1.Amount.AsString := XBuffer;
PendOp := Key;
Key := #0;
ClearOnNext := True;
end else begin
HldOp := PendOp;
PendOp := Key;
EqualBtnClick(Sender);
PendOp := HldOp;
Key := #0;
end;
end;
if (Key in MoneyChar) then begin
S := Memo1.Lines[0];
L := Length(S);
if (L < Memo1.MaxLength) then begin
Memo1.Lines[0] := S + Key;
end;
Key := #0
end;
Memo1.SetFocus;
Memo1.SelStart := Length(Memo1.Lines[0]);
Memo1.SelLength := 0;
finally
Money1.Free;
end;
end;
procedure TMoneyCalcDlg.EqualBtnClick(Sender: TObject);
var
S : AnsiString;
RV, Money : TStMoney;
begin
RV := TStMoney.Create;
Money := TStMoney.Create;
try
if PendOp <> #0 then begin
S := Memo1.Lines[0];
if S = '' then begin
{$IFDEF FPC}
Beep;
{$ELSE}
MessageBeep(0);
{$ENDIF}
Exit;
end;
RV.Amount.AsString := XBuffer;
Money.Amount.AsString := S;
case PendOp of
'+' : begin
RV.Add(Money, RV);
Memo1.Lines[0] := RV.AsString;
end;
'-' : begin
RV.Subtract(Money, RV);
Memo1.Lines[0] := RV.AsString;
end;
'*' : begin
RV.Multiply(StrToFloat(S), RV);
Memo1.Lines[0] := RV.AsString;
end;
'/' : begin
if Money.IsZero then begin
Memo1.Lines[0] := 'Divide by zero error';
PendOp := #0;
ClearOnNext := False;
end else begin
RV.Divide(StrToFloat(S), RV);
Memo1.Lines[0] := RV.AsString;
end;
end;
end; { case }
end;
PendOp := #0;
ClearOnNext := True;
Memo1.SetFocus;
Memo1.SelStart := 0;
Memo1.SelLength := 0;
finally
Money.Free;
RV.Free;
end;
end;
procedure TMoneyCalcDlg.UpdateCurrencyCombo;
var
i : Integer;
begin
ComboBox1.Items.BeginUpdate;
ComboBox1.Items.Clear;
for i := 0 to Pred(Currencies.Count) do
ComboBox1.Items.Add(Currencies.Items[i].ISOName);
ComboBox1.Text := '';
ComboBox1.Items.EndUpdate;
end;
procedure TMoneyCalcDlg.UpdateConversionCombo;
var
i : Integer;
begin
ComboBox2.Items.BeginUpdate;
ComboBox2.Items.Clear;
for i := 0 to Pred(Conversions.Count) do
if Conversions.Items[i].Source = BaseCurrency then
ComboBox2.Items.Add(Conversions.Items[i].Target);
ComboBox2.Text := '';
ComboBox2.Items.EndUpdate;
ListBox2.Clear;
end;
procedure TMoneyCalcDlg.ShowCurrencyData(const Name : string);
var
Cur : TStCurrency;
begin
Cur := Currencies.Currencies[Name];
ListBox1.Items.Clear;
ListBox1.Items.Add('Name: ' + Cur.Name);
ListBox1.Items.Add('ISOName: ' + Cur.ISOName);
ListBox1.Items.Add('ISOCode: ' + Cur.ISOCode);
ListBox1.Items.Add('Major: ' + Cur.UnitMajor);
ListBox1.Items.Add('Minor: ' + Cur.UnitMinor);
if ComboBox2.Text <> '' then
ShowExchangeData(Name, ComboBox2.Text);
end;
procedure TMoneyCalcDlg.ComboBox1Change(Sender: TObject);
begin
BaseCurrency := ComboBox1.Text;
UpdateConversionCombo;
UpdateFormCaption;
ShowCurrencyData(BaseCurrency);
end;
procedure TMoneyCalcDlg.ConvertBtnClick(Sender: TObject);
var
CV : TStMoney;
begin
CV := TStMoney.Create;
try
CV.ExchangeRates := Conversions;
CV.Amount.AsString := Memo1.Lines[0];
CV.Currency := ComboBox1.Text;
CV.Convert(ComboBox2.Text, CV);
Memo1.Lines[0] := CV.AsString;
finally
CV.Free;
end;
end;
procedure TMoneyCalcDlg.ShowExchangeData(const src, trg : string);
var
Cur : TStCurrency;
Rate : TStExchangeRate;
begin
Cur := Currencies.Currencies[trg];
Rate := Conversions.Rates[src, trg];
ListBox2.Items.Clear;
case Rate.ConversionType of
ctTriangular: begin
ListBox2.Items.Add('Name:' + #9 + Cur.Name);
ListBox2.Items.Add(src + '->' + trg + ' inter.: ' + Rate.Intermediate);
end;
ctMultiply: begin
ListBox2.Items.Add('Name: ' + #9 + Cur.Name);
ListBox2.Items.Add(src + '->' + trg + ' multiply by: ' + Rate.Rate.AsString);
end;
ctDivide: begin
ListBox2.Items.Add('Name: ' + #9 + Cur.Name);
ListBox2.Items.Add(src + '->' + trg + ' divide by: ' + Rate.Rate.AsString);
end;
end;
end;
procedure TMoneyCalcDlg.ComboBox2Change(Sender: TObject);
begin
ShowExchangeData(ComboBox1.Text, ComboBox2.Text);
end;
procedure GetRateAndDate(var Rate, Date: string);
begin
end;
procedure TMoneyCalcDlg.DoRateUpdate(Sender: TObject;
NewRate : TStDecimal; var NewDate : TDateTime);
var
ARate, ADate : string;
begin
GetRateAndDate(ARate, ADate);
NewRate.AsString := ARate;
NewDate := StrToDateTime(ADate);
end;
procedure TMoneyCalcDlg.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_DOWN then
Key := 0;
end;
procedure TMoneyCalcDlg.BSBtnClick(Sender: TObject);
begin
Memo1.Lines[0] := Copy(Memo1.Lines[0], 1, Length(Memo1.Lines[0]) - 1);
if Length(Memo1.Lines[0]) = 0 then
ClearBtnClick(ClearBtn);
end;
procedure TMoneyCalcDlg.Copy1Click(Sender: TObject);
begin
Memo1.SelectAll;
Memo1.CopyToClipboard;
Memo1.SelStart := 0;
end;
procedure TMoneyCalcDlg.Paste1Click(Sender: TObject);
var
S : string;
IsNeg : Boolean;
begin
IsNeg := False;
S := Clipboard.AsText;
if (S[1] = '-') then begin
IsNeg := True;
S := Copy(S, 2, Length(S) - 1);
end;
if IsStrNumericL(S, '0123456789' + SysUtils.DecimalSeparator) then begin
if IsNeg then S := '-' + S;
Memo1.Lines[0] := S;
end;
end;
end.

81
components/systools/examples/money_calculator/moneycalc.lpi Normal file
View File

@ -0,0 +1,81 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="moneycalc"/>
<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="moneycalc.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="MonyCalc"/>
</Unit0>
<Unit1>
<Filename Value="moneycal0.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="MoneyCalcDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="moneycalc"/>
</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>

38
components/systools/examples/money_calculator/moneycalc.lpr Normal file
View File

@ -0,0 +1,38 @@
(* ***** 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 ***** *)
program MoneyCalc;
uses
Forms, Interfaces,
moneycal0 in 'moneycal0.pas' {MoneyCalcDlg};
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TMoneyCalcDlg, MoneyCalcDlg);
Application.Run;
end.

123
components/systools/laz_systools.lpk Normal file
View File

@ -0,0 +1,123 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_systools"/>
<Author Value="Original author: TurboPower Software"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source\include;source\run"/>
<OtherUnitFiles Value="source\run"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\run"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - runtime package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="21">
<Item1>
<Filename Value="source\run\stbarc.pas"/>
<UnitName Value="StBarC"/>
</Item1>
<Item2>
<Filename Value="source\run\stbase.pas"/>
<UnitName Value="StBase"/>
</Item2>
<Item3>
<Filename Value="source\run\stconst.pas"/>
<UnitName Value="StConst"/>
</Item3>
<Item4>
<Filename Value="source\run\stbarpn.pas"/>
<UnitName Value="StBarPN"/>
</Item4>
<Item5>
<Filename Value="source\run\ststrl.pas"/>
<UnitName Value="StStrL"/>
</Item5>
<Item6>
<Filename Value="source\include\stdefine.inc"/>
<Type Value="Include"/>
</Item6>
<Item7>
<Filename Value="source\run\st2dbarc.pas"/>
<UnitName Value="St2DBarC"/>
</Item7>
<Item8>
<Filename Value="source\run\stdate.pas"/>
<UnitName Value="StDate"/>
</Item8>
<Item9>
<Filename Value="source\run\stutils.pas"/>
<UnitName Value="StUtils"/>
</Item9>
<Item10>
<Filename Value="source\run\stcrc.pas"/>
<UnitName Value="StCRC"/>
</Item10>
<Item11>
<Filename Value="source\run\sthash.pas"/>
<UnitName Value="StHASH"/>
</Item11>
<Item12>
<Filename Value="source\run\sttohtml.pas"/>
<UnitName Value="StToHTML"/>
</Item12>
<Item13>
<Filename Value="source\run\ststrms.pas"/>
<UnitName Value="StStrms"/>
</Item13>
<Item14>
<Filename Value="source\run\stdict.pas"/>
<UnitName Value="StDict"/>
</Item14>
<Item15>
<Filename Value="source\run\stinistm.pas"/>
<UnitName Value="StIniStm"/>
</Item15>
<Item16>
<Filename Value="source\run\stdecmth.pas"/>
<UnitName Value="StDecMth"/>
</Item16>
<Item17>
<Filename Value="source\run\stexpr.pas"/>
<UnitName Value="StExpr"/>
</Item17>
<Item18>
<Filename Value="source\run\stmath.pas"/>
<UnitName Value="StMath"/>
</Item18>
<Item19>
<Filename Value="source\run\stfin.pas"/>
<UnitName Value="StFIN"/>
</Item19>
<Item20>
<Filename Value="source\run\stdatest.pas"/>
<UnitName Value="StDateSt"/>
</Item20>
<Item21>
<Filename Value="source\run\stmoney.pas"/>
<UnitName Value="StMoney"/>
</Item21>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>

17
components/systools/laz_systools.pas Normal file
View File

@ -0,0 +1,17 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_systools;
{$warn 5023 off : no warning about unused units}
interface
uses
StBarC, StBase, StConst, StBarPN, StStrL, St2DBarC, StDate, StUtils, StCRC,
StHASH, StToHTML, StStrms, StDict, StIniStm, StDecMth, StExpr, StMath,
StFIN, StDateSt, StMoney;
implementation
end.

42
components/systools/laz_systools_design.lpk Normal file
View File

@ -0,0 +1,42 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_systools_design"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Original author: TurboPower Software"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source\include"/>
<OtherUnitFiles Value="source\design"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\design"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools (Delphi version at https://sourceforge.net/projects/tpsystools/) - designtime package."/>
<License Value="MPL-1.1"/>
<Version Major="4" Release="4"/>
<Files Count="1">
<Item1>
<Filename Value="source\design\StReg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="StReg"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

22
components/systools/laz_systools_design.pas Normal file
View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_systools_design;
{$warn 5023 off : no warning about unused units}
interface
uses
StReg, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('StReg', @StReg.Register);
end;
initialization
RegisterPackage('laz_systools_design', @Register);
end.

51
components/systools/laz_systoolsdb.lpk Normal file
View File

@ -0,0 +1,51 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_systoolsdb"/>
<Author Value="Turbo Power Software"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source\include;source\db"/>
<OtherUnitFiles Value="source\db"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\run-db"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of Turbo Power SysTools database components - runtime package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="3">
<Item1>
<Filename Value="source\db\stdb2dbc.pas"/>
<UnitName Value="StDb2DBC"/>
</Item1>
<Item2>
<Filename Value="source\db\stdbbarc.pas"/>
<UnitName Value="StDbBarC"/>
</Item2>
<Item3>
<Filename Value="source\db\stdbpnbc.pas"/>
<UnitName Value="StDbPNBC"/>
</Item3>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

15
components/systools/laz_systoolsdb.pas Normal file
View File

@ -0,0 +1,15 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_systoolsdb;
{$warn 5023 off : no warning about unused units}
interface
uses
StDb2DBC, StDbBarC, StDbPNBC;
implementation
end.

45
components/systools/laz_systoolsdb_design.lpk Normal file
View File

@ -0,0 +1,45 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_systoolsdb_design"/>
<Type Value="DesignTime"/>
<Author Value="TurboPower Software"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="source\design"/>
<OtherUnitFiles Value="source\design"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Lazarus port of TurboPower SysTools database components - designtime package"/>
<License Value="MPL 1.1"/>
<Version Major="4" Release="4"/>
<Files Count="1">
<Item1>
<Filename Value="source\design\StRegDb.pas"/>
<HasRegisterProc Value="True"/>
<AddToUsesPkgSection Value="False"/>
</Item1>
</Files>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="IDEIntf"/>
</Item1>
<Item2>
<PackageName Value="laz_systoolsdb"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

22
components/systools/laz_systoolsdb_design.pas Normal file
View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_systoolsdb_design;
{$warn 5023 off : no warning about unused units}
interface
uses
StRegDb, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('StRegDb', @StRegDb.Register);
end;
initialization
RegisterPackage('laz_systoolsdb_design', @Register);
end.

78
components/systools/readme.txt Normal file
View File

@ -0,0 +1,78 @@
TurboPower SysTools
Table of contents
1. Introduction
2. Package names
3. Installation
4. Version history
4.1 Release 4.03
==============================================
1. Introduction
SysTools is a library of utility routines & classes for Borland
Delphi, C++Builder, & environments that support COM. It includes 1-D &
2-D bar codes, sorting, money routines, logging, high-precision math,
a run-time math expression analyzer, & much more.
This is a source-only release of TurboPower SysTools. It includes
designtime and runtime packages for Delphi 3 through 7 and C++Builder
3 through 6.
==============================================
2. Package names
TurboPower SysTools package names have the following form:
SNNN_KVV.*
| ||
| |+------ VV VCL version (30=Delphi 3, 40=Delphi 4, 70=Delphi 7)
| +------- K Kind of package (R=runtime, D=designtime)
|
+----------- NNN Product version number (e.g., 403=version 4.03)
For example, the SysTools designtime package files for Delphi 7 have
the filename S403_D70.*.
==============================================
3. Installation
To install TurboPower SysTools into your IDE, take the following
steps:
1. Unzip the release files into a directory (e.g., d:\systools).
2. Start Delphi or C++Builder.
3. Add the source subdirectory (e.g., d:\systools\source) to the
IDE's library path.
4. Open & install the designtime package specific to the IDE being
used. The IDE should notify you the components have been
installed.
5. Make sure the PATH environmental variable contains the directory
in which the compiled packages (i.e., BPL or DPL files) were
placed.
==============================================
4. Version history
4.1 Release 4.03
Bug fixes
-------------------------------------------------------------
- Range error in TimeToTimeStringPrim Routine
- Added empty string case handling to TrimLeadS

64
components/systools/readme404pre.txt Normal file
View File

@ -0,0 +1,64 @@
TurboPower SysTools -- Version 4.04 Pre-Release
Table of contents
1. Introduction
2. Package names
3. Installation
==============================================
1. Introduction
This is a "pre-release" of SysTools version 4.04. It contains only the
Delphi packages for Delphi 2005 and Delphi 2006. It does not contain any
other enhancements or bug fixes that may have been made since the release of
version 4.03. To compile the Delphi 2005 and Delphi 2006 packages, you will
still need all of the source files from version 4.03.
==============================================
2. Package names
The Delphi 2005 runtime packages are S404_R90.dpk and S404BR90.dpk. The
designtime packages are S404_D90.dpk and S404BD90.dpk.
The Delphi 2006 runtime packages are S404_R100.dpk and S404BR100.dpk. The
designtime packages are S404_D100.dpk and S404BD100.dpk.
==============================================
3. Installation
To install TurboPower SysTools into your Delphi 2005 or 2006 IDE, take the following steps:
1. Unzip the release files into the packages directory of your SysTools 4.03 installation
(e.g., c:\turbopower\systools\packages).
2. Start Delphi 2005 or 2006.
3. Add the source subdirectory (e.g., c:\turbopower\systools\source) to the IDE's
library path.
4. Open & compile the runtime packages specific to the IDE being used.
(S404_R90.bdsproj and S404BR90.bdsproj for Delphi 2005, and S404_R100.bdsproj
and S404BR100.bdsproj for Delphi 2006.)
5. Open & compile the designtime packages specific to the IDE being used.
(S404_D90.bdsproj and S404BD90.bdsproj for Delphi 2005, and S404_D100.bdsproj
and S404BD100.bdsproj for Delphi 2006.)
6. Install the designtime packages into the IDE by using the Component/Install
Packages menu option. From there, click the "Add" button and then navigate
to the location of your newly-compiled designtime packages. (S404_D90.bpl and
S404BD90.bpl for Delphi 2005, and S404_D100.bpl and S404BD100.bpl for Delphi
2006.) By default, the Delphi compiler places the compiled packages in the
C:\Documents and Settings\<Your User Name>\My Documents\Borland Studio Projects\Bpl
directory.

358
components/systools/source/db/stdb2dbc.pas Normal file
View File

@ -0,0 +1,358 @@
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDb2DBC.pas 4.04 *}
{*********************************************************}
{* SysTools: Data-aware Two-Dimensional Barcodes *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StDb2DBC;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
SysUtils,
Classes,
St2DBarC,
Db,
DbCtrls;
type
TStDbPDF417Barcode = class(TStPDF417Barcode)
protected {private}
{.Z+}
FCaptionDataLink : TFieldDataLink;
FCodeDataLink : TFieldDataLink;
procedure CaptionDataChange(Sender : TObject);
procedure CodeDataChange(Sender : TObject);
function GetCaptionDataField : string;
function GetCodeDataField : string;
function GetDataSource : TDataSource;
procedure SetCaptionDataField(const Value : string);
procedure SetCodeDataField(const Value : string);
procedure SetDataSource(Value : TDataSource);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy;
override;
{.Z+}
published
property Code stored False;
property Caption stored False;
property CaptionDataField : string
read GetCaptionDataField write SetCaptionDataField;
property CodeDataField : string
read GetCodeDataField write SetCodeDataField;
property DataSource : TDataSource read GetDataSource write SetDataSource;
end;
TStDbMaxiCodeBarcode = class(TStMaxiCodeBarcode)
protected {private}
{.Z+}
FCaptionDataLink : TFieldDataLink;
FCodeDataLink : TFieldDataLink;
FCountryCodeDataLink : TFieldDataLink;
FPostalCodeDataLink : TFieldDataLink;
FServiceClassDataLink : TFieldDataLink;
procedure CaptionDataChange (Sender : TObject);
procedure CodeDataChange (Sender : TObject);
procedure CountryCodeChange (Sender : TObject);
function GetCaptionDataField : string;
function GetCodeDataField : string;
function GetCountryCodeDataField : string;
function GetDataSource : TDataSource;
function GetPostalCodeDataField : string;
function GetServiceClassDataField : string;
procedure PostalCodeChange (Sender : TObject);
procedure ServiceClassChange (Sender : TObject);
procedure SetCaptionDataField (const Value : string);
procedure SetCodeDataField (const Value : string);
procedure SetCountryCodeDataField (const Value : string);
procedure SetDataSource (Value : TDataSource);
procedure SetPostalCodeDataField (const Value : string);
procedure SetServiceClassDataField (const Value : string);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy;
override;
{.Z+}
published
property Code stored False;
property Caption stored False;
property CaptionDataField : string
read GetCaptionDataField write SetCaptionDataField;
property CarrierCountryCodeDataField : string
read GetCountryCodeDataField write SetCountryCodeDataField;
property CarrierPostalCodeDataField : string
read GetPostalCodeDataField write SetPostalCodeDataField;
property CarrierServiceClassDataField : string
read GetServiceClassDataField write SetServiceClassDataField;
property CodeDataField : string
read GetCodeDataField write SetCodeDataField;
property DataSource : TDataSource read GetDataSource write SetDataSource;
end;
implementation
{ TStDbPDF417Barcode }
constructor TStDbPDF417Barcode.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FCaptionDataLink := TFieldDataLink.Create;
FCaptionDataLink.OnDataChange := CaptionDataChange;
FCodeDataLink := TFieldDataLink.Create;
FCodeDataLink.OnDataChange := CodeDataChange;
end;
destructor TStDbPDF417Barcode.Destroy;
begin
FCaptionDataLink.OnDataChange := nil;
FCaptionDataLink.Free;
FCaptionDataLink := nil;
FCodeDataLink.OnDataChange := nil;
FCodeDataLink.Free;
FCodeDataLink := nil;
inherited Destroy;
end;
procedure TStDbPDF417Barcode.CaptionDataChange(Sender : TObject);
begin
if FCaptionDataLink.Field = nil then
Caption := '12345678922'
else
Caption := FCaptionDataLink.Field.DisplayText;
end;
procedure TStDbPDF417Barcode.CodeDataChange(Sender : TObject);
begin
if FCodeDataLink.Field = nil then
Code := '12345678922'
else
Code := FCodeDataLink.Field.DisplayText;
end;
function TStDbPDF417Barcode.GetCaptionDataField : string;
begin
Result := FCaptionDataLink.FieldName;
end;
function TStDbPDF417Barcode.GetCodeDataField : string;
begin
Result := FCodeDataLink.FieldName;
end;
function TStDbPDF417Barcode.GetDataSource : TDataSource;
begin
Result := FCaptionDataLink.DataSource
end;
procedure TStDbPDF417Barcode.SetCaptionDataField(const Value : string);
begin
FCaptionDataLink.FieldName := Value;
end;
procedure TStDbPDF417Barcode.SetCodeDataField(const Value : string);
begin
FCodeDataLink.FieldName := Value;
end;
procedure TStDbPDF417Barcode.SetDataSource(Value : TDataSource);
begin
FCaptionDataLink.DataSource := Value;
FCodeDataLink.DataSource := Value;
end;
{ TStDbMaxiCodeBarcode }
constructor TStDbMaxiCodeBarcode.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FCaptionDataLink := TFieldDataLink.Create;
FCaptionDataLink.OnDataChange := CaptionDataChange;
FCodeDataLink := TFieldDataLink.Create;
FCodeDataLink.OnDataChange := CodeDataChange;
FCountryCodeDataLink := TFieldDataLink.Create;
FCountryCodeDataLink.OnDataChange := CountryCodeChange;
FPostalCodeDataLink := TFieldDataLink.Create;
FPostalCodeDataLink.OnDataChange := PostalCodeChange;
FServiceClassDataLink := TFieldDataLink.Create;
FServiceClassDataLink.OnDataChange := ServiceClassChange;
end;
destructor TStDbMaxiCodeBarcode.Destroy;
begin
FCaptionDataLink.OnDataChange := nil;
FCaptionDataLink.Free;
FCaptionDataLink := nil;
FCodeDataLink.OnDataChange := nil;
FCodeDataLink.Free;
FCodeDataLink := nil;
FCountryCodeDataLink.OnDataChange := nil;
FCountryCodeDataLink.Free;
FCountryCodeDataLink := nil;
FPostalCodeDataLink.OnDataChange := nil;
FPostalCodeDataLink.Free;
FPostalCodeDataLink := nil;
FServiceClassDataLink.OnDataChange := nil;
FServiceClassDataLink.Free;
FServiceClassDataLink := nil;
inherited Destroy;
end;
procedure TStDbMaxiCodeBarcode.CaptionDataChange(Sender : TObject);
begin
if FCaptionDataLink.Field = nil then
Caption := '12345678922'
else
Caption := FCaptionDataLink.Field.DisplayText;
end;
procedure TStDbMaxiCodeBarcode.CodeDataChange(Sender : TObject);
begin
if FCodeDataLink.Field = nil then
Code := '12345678922'
else
Code := FCodeDataLink.Field.DisplayText;
end;
procedure TStDbMaxiCodeBarcode.CountryCodeChange (Sender : TObject);
begin
if FCountryCodeDataLink.Field = nil then
CarrierCountryCode := 0
else
CarrierCountryCode := FCountryCodeDataLink.Field.AsInteger;
end;
function TStDbMaxiCodeBarcode.GetCaptionDataField : string;
begin
Result := FCaptionDataLink.FieldName;
end;
function TStDbMaxiCodeBarcode.GetCodeDataField : string;
begin
Result := FCodeDataLink.FieldName;
end;
function TStDbMaxiCodeBarcode.GetCountryCodeDataField : string;
begin
Result := FCountryCodeDataLink.FieldName;
end;
function TStDbMaxiCodeBarcode.GetDataSource : TDataSource;
begin
Result := FCaptionDataLink.DataSource
end;
function TStDbMaxiCodeBarcode.GetPostalCodeDataField : string;
begin
Result := FPostalCodeDataLink.FieldName;
end;
function TStDbMaxiCodeBarcode.GetServiceClassDataField : string;
begin
Result := FServiceClassDataLink.FieldName;
end;
procedure TStDbMaxiCodeBarcode.PostalCodeChange (Sender : TObject);
begin
if FPostalCodeDataLink.Field = nil then
CarrierPostalCode := '000'
else
CarrierPostalCode := FPostalCodeDataLink.Field.DisplayText;
end;
procedure TStDbMaxiCodeBarcode.ServiceClassChange (Sender : TObject);
begin
if FServiceClassDataLink.Field = nil then
CarrierServiceClass := 0
else
CarrierServiceClass := FServiceClassDataLink.Field.AsInteger;
end;
procedure TStDbMaxiCodeBarcode.SetCaptionDataField(const Value : string);
begin
FCaptionDataLink.FieldName := Value;
end;
procedure TStDbMaxiCodeBarcode.SetCodeDataField(const Value : string);
begin
FCodeDataLink.FieldName := Value;
end;
procedure TStDbMaxiCodeBarcode.SetCountryCodeDataField (const Value : string);
begin
FCountryCodeDataLink.FieldName := Value;
end;
procedure TStDbMaxiCodeBarcode.SetDataSource(Value : TDataSource);
begin
FCaptionDataLink.DataSource := Value;
FCodeDataLink.DataSource := Value;
FCountryCodeDataLink.DataSource := Value;
FPostalCodeDataLink.DataSource := Value;
FServiceClassDataLink.DataSource := Value;
end;
procedure TStDbMaxiCodeBarcode.SetPostalCodeDataField (const Value : string);
begin
FPostalCodeDataLink.FieldName := Value;
end;
procedure TStDbMaxiCodeBarcode.SetServiceClassDataField (const Value : string);
begin
FServiceClassDataLink.FieldName := Value;
end;
end.

136
components/systools/source/db/stdbbarc.pas Normal file
View File

@ -0,0 +1,136 @@
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDbBarC.pas 4.04 *}
{*********************************************************}
{* SysTools: data aware bar code components *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StDbBarC;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages, DbTables,
{$ENDIF}
Classes, //ClipBrd,
Controls, Graphics, SysUtils,
Db, DbCtrls,
StConst, StBarC;
type
TStDbBarCode = class(TStBarCode)
protected {private}
{.Z+}
FDataLink : TFieldDataLink;
procedure DataChange(Sender : TObject);
function GetDataField : string;
function GetDataSource : TDataSource;
procedure SetDataField(const Value : string);
procedure SetDataSource(Value : TDataSource);
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z+}
published
property Code
stored False;
property DataField : string
read GetDataField
write SetDataField;
property DataSource : TDataSource
read GetDataSource
write SetDataSource;
end;
implementation
{*** TStDbBarCode ***}
constructor TStDbBarCode.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
end;
procedure TStDbBarCode.DataChange(Sender : TObject);
begin
if FDataLink.Field = nil then
Code := '12345678922'
else
Code := FDataLink.Field.DisplayText;
end;
destructor TStDbBarCode.Destroy;
begin
FDataLink.OnDataChange := nil;
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
function TStDbBarCode.GetDataField : string;
begin
Result := FDataLink.FieldName;
end;
function TStDbBarCode.GetDataSource : TDataSource;
begin
Result := FDataLink.DataSource
end;
procedure TStDbBarCode.SetDataField(const Value : string);
begin
FDataLink.FieldName := Value;
end;
procedure TStDbBarCode.SetDataSource(Value : TDataSource);
begin
FDataLink.DataSource := Value;
end;
end.

133
components/systools/source/db/stdbpnbc.pas Normal file
View File

@ -0,0 +1,133 @@
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDbPNBC.pas 4.04 *}
{*********************************************************}
{* SysTools: data aware PostNet Bar Code component *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I STDEFINE.INC}
unit StDbPNBC;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages, DBTables,
{$ENDIF}
Classes, ClipBrd, Controls, Graphics, SysUtils,
Db, DbCtrls,
StConst, StBarPN;
type
TStDbPNBarCode = class(TStPNBarCode)
protected {private}
{.Z+}
FDataLink : TFieldDataLink;
procedure DataChange(Sender : TObject);
function GetDataField : string;
function GetDataSource : TDataSource;
procedure SetDataField(const Value : string);
procedure SetDataSource(Value : TDataSource);
public
constructor Create(AOwner : TComponent);
override;
destructor Destroy;
override;
{.Z+}
published
property PostalCode
stored False;
property DataField : string
read GetDataField
write SetDataField;
property DataSource : TDataSource
read GetDataSource
write SetDataSource;
end;
implementation
{*** TStDbPNBarCode ***}
constructor TStDbPNBarCode.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FDataLink := TFieldDataLink.Create;
FDataLink.OnDataChange := DataChange;
end;
procedure TStDbPNBarCode.DataChange(Sender : TObject);
begin
if FDataLink.Field = nil then
PostalCode := '12345'
else
PostalCode := FDataLink.Field.DisplayText;
end;
destructor TStDbPNBarCode.Destroy;
begin
FDataLink.OnDataChange := nil;
FDataLink.Free;
FDataLink := nil;
inherited Destroy;
end;
function TStDbPNBarCode.GetDataField : string;
begin
Result := FDataLink.FieldName;
end;
function TStDbPNBarCode.GetDataSource : TDataSource;
begin
Result := FDataLink.DataSource
end;
procedure TStDbPNBarCode.SetDataField(const Value : string);
begin
FDataLink.FieldName := Value;
end;
procedure TStDbPNBarCode.SetDataSource(Value : TDataSource);
begin
FDataLink.DataSource := Value;
end;
end.

239
components/systools/source/design/StReg.pas Normal file
View File

@ -0,0 +1,239 @@
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StReg.pas 4.04 *}
{*********************************************************}
{* SysTools: Component Registration Unit *}
{*********************************************************}
//{$I StDefine.inc}
{$R StReg.r32}
unit StReg;
interface
uses
Classes
{$IFDEF FPC}
;//PropEdits //, LazarusPackageIntf //, FieldsEditor, ComponentEditors
{$ELSE}
{$IFDEF VERSION6}
DesignIntf,
DesignEditorsM
{$ELSE}
DsgnIntfM
{$ENDIF}
{$ENDIF}
procedure Register;
implementation
uses
StBase,
// StAbout0,
{ components }
St2DBarC,
StBarC,
StBarPN,
(*,
StNetCon,
StNetMsg,
StNetPfm,
StNVBits,
StNVColl,
StNVDict,
StNVDQ,
StNVLAry,
StNVList,
StNVLMat,
StNVSCol,
StNVTree,
StRegEx,
StSpawn,
*)
StToHTML,
(*
StVInfo,
StWMDCpy,
{forces these units to be compiled when components are installed}
{vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv}
StAstro,
StAstroP,
StBCD,
StBits,
StColl,
*)
StConst,
StCrc,
StDate,
(*
StDateSt,
StDict,
StDQue,
StEclpse,
*)
StExpr,
StFIN,
(*
StFirst,
StHASH,
StJup,
StJupsat,
StLArr,
StList,
StMars,
*)
StMath,
(*
StMerc,
StMime,
StNeptun,
StNet,
StNetApi,
StNVCont,
StOStr,
StPluto,
StPQueue,
StRegIni,
StSaturn,
StSort,
StStat,
StStrL,
StStrms,
StStrS,
StStrW,
StStrZ,
StText,
StTree,
StUranus,
*)
StUtils,
(*
StVArr,
StVenus,
{ new units in ver 4: }
StIniStm,
StMerge,
StSystem,
StTxtDat,
StDecMth,
*)
StMoney
(*
StRandom,
StNTLog,
{ !!! StExpEng unit designed to handle problem with initialization }
{ section in C++Builder; should NOT be included in Registration unit }
{ nor in Run-time package !!! }
{StExpEng,}
StExpLog,
StGenLog,
StPtrns,
{^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^}
StPropEd
*);
procedure Register;
begin
(*
RegisterPropertyEditor(TypeInfo(string), TStComponent, 'Version',
TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStBaseEdit, 'Version',
TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStBarCode, 'Version',
TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStPNBarCode, 'Version',
TStVersionProperty);
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'InputFile',
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStRegEx, 'OutputFile',
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStFileToHTML, 'InFileName',
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStFileToHTML, 'OutFileName',
TStGenericFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStVersionInfo, 'FileName',
TStFileNameProperty);
RegisterPropertyEditor(TypeInfo(string), TStSpawnApplication, 'FileName',
TStGenericFileNameProperty);
*)
RegisterComponents('SysTools',
[
{
TStNetConnection,
TStNetPerformance,
TStNetMessage,
TStVersionInfo,
}
TStExpression,
TStExpressionEdit,
TStBarCode,
TStPNBarCode,
{
TStRegEx,
TStWMDataCopy,
}
TStFileToHTML,
{
TStSpawnApplication,
}
// new in SysTools 4
TStPDF417Barcode,
TStMaxiCodeBarcode
{
TStGeneralLog,
{.$IFNDEF BCB} {!!! problem with initialization section in BCB }
TStExceptionLog,
{.$ENDIF}
TStNTEventLog
}
]);
(*
{non-visual container class components}
RegisterComponents('SysTools (CC)',
[TStNVBits,
TStNVCollection,
TStNVDictionary,
TStNVDQue,
TStNVLArray,
TStNVList,
TStNVLMatrix,
TStNVSortedCollection,
TStNVTree]);
*)
end;
end.

945
components/systools/source/design/StReg.rc Normal file
View File

@ -0,0 +1,945 @@
/* ***** 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 ***** */
/****************************************************************************
streg.rc
produced by Borland Resource Workshop
*****************************************************************************/
STTEMPLATE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTBARCODE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 03 33 33 33 33 33 33 33 33'
'30 33 33 03 33 33 33 33 33 33 33 33 30 33 33 03'
'03 00 30 30 33 00 30 30 30 33 33 03 03 00 30 30'
'33 00 30 30 30 33 33 03 03 00 30 30 33 00 30 30'
'30 33 33 03 03 00 30 30 33 00 30 30 30 33 33 03'
'03 00 30 30 33 00 30 30 30 33 33 03 03 00 30 30'
'33 00 30 30 30 33 33 03 03 00 30 30 33 00 30 30'
'30 33 33 03 03 00 30 30 33 00 30 30 30 33 33 03'
'03 00 30 30 33 00 30 30 30 33 33 03 03 00 30 30'
'33 00 30 30 30 33 33 03 03 00 30 30 33 00 30 30'
'30 33 33 03 03 00 30 30 33 00 30 30 30 33 33 03'
'03 00 30 30 33 00 30 30 30 33 33 03 33 33 33 33'
'33 33 33 33 30 33 33 03 33 33 33 33 33 33 33 33'
'30 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
LANGUAGE LANG_ENGLISH,SUBLANG_ENGLISH_US
TSTCODE16KBARCODE BITMAP LOADONCALL MOVEABLE DISCARDABLE IMPURE
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 00 00 00 00 00'
'00 00 00 00 00 33 33 33 30 00 30 30 03 30 03 03'
'33 33 33 33 30 00 30 30 03 30 03 03 33 33 33 33'
'30 00 30 30 03 30 03 03 33 33 33 33 30 00 30 30'
'03 30 03 03 33 33 33 33 30 00 30 30 03 30 03 03'
'33 33 33 33 30 00 00 00 00 00 00 03 33 33 33 33'
'30 30 03 03 03 00 33 03 33 33 33 33 30 30 03 03'
'03 00 33 03 33 33 33 33 30 30 03 03 03 00 33 03'
'33 33 33 33 30 30 03 03 03 00 33 03 33 33 33 33'
'30 30 03 03 03 00 33 03 33 33 33 33 30 00 00 00'
'00 00 00 03 33 33 33 33 30 03 03 33 00 03 03 03'
'33 33 33 33 30 03 03 33 00 03 03 03 33 33 33 33'
'30 03 03 33 00 03 03 03 33 33 33 33 30 03 03 33'
'00 03 03 03 33 33 33 33 30 03 03 33 00 03 03 03'
'33 33 33 00 00 00 00 00 00 00 00 00 00 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTDATAMATRIXBARCODE BITMAP LOADONCALL MOVEABLE DISCARDABLE IMPURE
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 30 00 00 00 00 00 00 00 00 00'
'03 33 30 00 00 00 00 00 00 00 00 00 03 33 30 00'
'03 30 00 00 00 03 33 33 33 33 30 00 03 30 00 00'
'00 03 33 33 33 33 30 00 03 33 33 30 00 03 33 30'
'03 33 30 00 03 33 33 30 00 03 33 30 03 33 30 03'
'30 00 00 00 00 00 00 03 33 33 30 03 30 00 00 00'
'00 00 00 03 33 33 30 03 30 03 30 00 00 00 03 30'
'03 33 30 03 30 03 30 00 00 00 03 30 03 33 30 00'
'00 03 33 30 03 30 03 33 33 33 30 00 00 03 33 30'
'03 30 03 33 33 33 30 00 00 00 00 03 33 30 03 30'
'03 33 30 00 00 00 00 03 33 30 03 30 03 33 30 00'
'00 03 33 33 33 30 03 33 33 33 30 00 00 03 33 33'
'33 30 03 33 33 33 30 00 03 33 33 30 00 03 33 30'
'03 33 30 00 03 33 33 30 00 03 33 30 03 33 30 03'
'33 33 30 00 00 03 33 33 33 33 30 03 33 33 30 00'
'00 03 33 33 33 33 30 03 33 30 03 33 33 33 33 30'
'03 33 30 03 33 30 03 33 33 33 33 30 03 33 30 03'
'30 03 30 03 30 03 30 03 33 33 30 03 30 03 30 03'
'30 03 30 03 33 33'
}
LANGUAGE LANG_NEUTRAL,SUBLANG_NEUTRAL
TSTEXPRESSION BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 30 33 33 33 33 33 33 33 33'
'33 33 33 30 33 33 33 33 33 33 30 33 33 33 03 30'
'33 33 33 33 03 33 30 33 33 33 03 33 33 33 33 33'
'03 33 33 03 33 30 33 30 33 03 33 33 03 33 33 30'
'33 03 33 33 33 03 33 33 03 33 33 33 00 33 33 33'
'00 00 03 33 03 33 33 33 00 33 33 33 33 03 33 33'
'03 33 33 30 33 03 33 33 33 03 33 33 03 33 33 03'
'33 30 33 33 33 33 33 33 03 33 30 33 33 33 03 33'
'33 33 33 00 03 33 30 33 33 33 03 33 33 33 33 33'
'03 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTEXPRESSIONEDIT BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 7F FF FF FF FF FF FF FF FF FF'
'FF F3 70 88 88 88 88 88 88 88 88 88 88 F3 70 FF'
'FF FF FF FF FF FF FF FF F8 F3 70 FF FF FF FF FF'
'CC CF 00 F0 08 F3 70 FF FF FF FF FF FC FF FF 0F'
'F8 F3 70 FF CC FC CF CC FC CC FF 0F F8 F3 70 FC'
'FF CF CF CF FC FF CF 0F F8 F3 70 FC FF FF FC FF'
'FC FF CF 0F F8 F3 70 FC CC CF FC FF FC FF CF 0F'
'F8 F3 70 FC FF CF CF CF FC FF CF 0F F8 F3 70 FF'
'CC FC CF CC CF CC FF 0F F8 F3 70 FF FF FF FF FF'
'FF FF FF 0F F8 F3 70 FF FF FF FF FF FF FF 00 F0'
'08 F3 70 FF FF FF FF FF FF FF FF FF F8 F3 70 00'
'00 00 00 00 00 00 00 00 00 F3 77 77 77 77 77 77'
'77 77 77 77 77 73 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTFILETOHTML BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD 0D'
'DD 0D D0 DD 0D DD D0 D0 00 DD DD 0D DD 0D D0 DD'
'0D 00 D0 D0 DD DD DD 0D DD 0D D0 DD 00 D0 D0 D0'
'DD DD DD 00 00 0D D0 DD 00 D0 D0 D0 DD DD DD 0D'
'DD 0D D0 DD 00 DD 00 D0 DD DD DD 0D DD 0D 00 0D'
'0D DD D0 D0 DD DD DD DD DD DD DD DD DD DD DD DD'
'DD DD DD 77 77 77 77 77 DD DD DD DD DD DD DF FF'
'FF FF FF F7 DD DD DD DD DD DD DF 0F 77 77 77 F7'
'DD DD DD DD DD DD DF FF FF FF FF F7 DD DD DD DD'
'DD DD DF 0F 00 00 00 F7 DD DD D4 DD DD DD DF FF'
'FF FF FF F7 DD DD 44 4D DD DD DF 0F 00 00 00 F7'
'DD D4 44 44 DD DD DF FF FF FF FF F7 DD 44 44 44'
'4D DD DF 0F 77 77 77 F7 DD DD 44 4D DD DD DF 0F'
'00 00 00 F7 DD DD 44 DD DD DD DF FF FF FF FF F7'
'D4 44 44 DD DD DD DF 0F 77 77 77 F7 D4 44 DD DD'
'DD DD DF FF FF FF FF FD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD'
}
LANGUAGE LANG_ENGLISH,SUBLANG_ENGLISH_US
TSTMAXICODEBARCODE BITMAP LOADONCALL MOVEABLE DISCARDABLE IMPURE
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 03'
'33 03 33 03 33 33 33 33 03 33 30 00 30 00 30 00'
'33 33 33 30 00 33 33 03 33 03 33 03 33 33 33 33'
'03 33 33 33 03 33 33 33 33 33 33 03 33 33 33 30'
'00 33 33 33 33 33 30 00 33 33 33 33 03 33 33 30'
'03 33 33 03 33 33 33 03 33 33 30 03 30 03 33 33'
'33 03 30 00 33 33 03 33 33 30 33 33 30 00 33 03'
'33 33 03 30 03 30 33 33 33 03 33 33 03 30 33 03'
'30 33 03 33 03 33 33 30 00 30 33 03 30 33 03 30'
'00 33 33 33 03 33 03 30 03 30 33 33 03 33 33 33'
'33 33 03 33 33 30 33 03 33 33 33 33 33 33 30 03'
'30 03 30 00 33 33 33 33 33 33 33 30 03 33 33 03'
'33 33 33 33 03 33 33 33 33 33 03 33 03 33 33 30'
'00 33 33 33 33 30 00 30 00 33 33 33 03 33 33 33'
'33 33 03 33 03 33 33 03 33 03 33 33 33 03 33 33'
'33 03 30 00 30 00 33 33 30 00 33 33 30 00 33 03'
'33 03 33 33 33 03 33 33 33 03 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
LANGUAGE LANG_NEUTRAL,SUBLANG_NEUTRAL
TSTNETCONNECTION BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 55 55 55 55 55 55 55 55 55 55'
'55 55 55 55 55 55 50 00 00 00 00 00 00 55 55 55'
'55 00 78 FF FF FF FF FF 87 05 55 55 55 05 78 77'
'77 77 77 77 87 75 55 55 55 05 78 88 88 88 88 88'
'87 75 55 55 55 05 78 88 88 88 88 A2 87 75 55 55'
'55 05 7F FF FF FF FF FF F7 75 55 04 44 44 57 88'
'88 88 88 88 88 75 50 07 77 77 55 77 77 77 77 77'
'77 75 50 78 F8 F8 85 55 55 55 55 55 55 55 50 80'
'00 00 00 55 55 55 55 55 55 55 55 08 FF FF F8 05'
'55 55 55 55 55 55 50 7F 7E EE EF 05 55 55 55 55'
'55 55 50 8F EF E8 6F 05 55 55 55 55 55 55 50 8F'
'EF FE 6F 04 44 44 45 55 55 55 50 8F 77 77 7F 07'
'87 87 75 55 55 55 50 8F FF FF F8 08 FF FF 75 55'
'55 55 5C 77 77 77 70 70 00 00 75 55 55 55 5C FE'
'2C EE C0 84 FE E4 75 55 55 55 55 C2 A2 2E E0 84'
'FF E4 75 55 55 55 55 2F 8A 22 20 87 77 74 75 55'
'55 55 55 52 2F A2 22 78 88 88 75 55 55 55 55 50'
'52 22 55 55 55 55 55 55 55 55 55 55 55 55 55 55'
'55 55 55 55 55 55'
}
TSTNETMESSAGE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 55 55 55 55 55 55 55 55 55 55'
'55 55 55 55 55 55 55 77 77 77 77 77 77 75 55 55'
'55 55 55 78 88 88 88 88 88 75 55 55 55 55 55 73'
'88 83 33 88 83 75 55 55 55 00 00 0B 38 30 00 38'
'38 75 55 55 55 05 55 7F F3 0F FB 03 88 75 55 55'
'55 05 55 7B 80 FB FF F0 38 75 55 04 44 44 44 78'
'0B FF FB FF 03 75 50 07 77 77 77 70 FF FB FF FB'
'F0 75 50 78 F8 F8 8F 7F FB FF FB FF FB 05 50 80'
'00 00 00 77 77 77 77 77 77 75 55 08 FF FF F8 05'
'55 55 55 55 55 55 50 7F 7E EE EF 05 55 55 55 55'
'55 55 50 8F EF E8 6F 05 55 55 55 55 55 55 50 8F'
'EF FE 6F 04 44 44 45 55 55 55 50 8F 77 77 7F 07'
'87 87 75 55 55 55 50 8F FF FF F8 08 FF FF 75 55'
'55 55 5C 77 77 77 70 70 00 00 75 55 55 55 5C FE'
'2C EE C0 84 FE E4 75 55 55 55 55 C2 A2 2E E0 84'
'FF E4 75 55 55 55 55 2F 8A 22 20 87 77 74 75 55'
'55 55 55 52 2F A2 22 78 88 88 75 55 55 55 55 55'
'52 22 55 55 55 55 55 55 55 55 55 55 55 55 55 55'
'55 55 55 55 55 55'
}
TSTNETPERFORMANCE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD DD 91 11 B3 33 A2 22 DD DD DD'
'DD DD DD 91 11 B3 33 A2 22 DD DD DD DD DD DD 91'
'11 B3 33 A2 22 DD DD DD DD 00 00 91 11 B3 33 A2'
'22 DD DD DD DD 0F FF 91 11 B3 33 A2 22 DD DD DD'
'DD 0F FF 99 99 B3 33 A2 22 DD DD 04 44 44 44 0D'
'DD B3 33 A2 22 DD D0 07 77 77 77 0D DD BB BB A2'
'22 DD D0 78 F8 F8 8F 0D DD DD DD A2 22 DD D0 80'
'00 00 00 0D DD DD DD A2 22 DD DD 08 FF FF F8 0D'
'DD DD DD AA AA DD D0 7F 7E EE EF 0D DD DD DD DD'
'DD DD D0 8F EF E8 6F 0D DD DD DD DD DD DD D0 8F'
'EF FE 6F 04 44 44 4D DD DD DD D0 8F 77 77 7F 07'
'87 87 7D DD DD DD D0 8F FF FF F8 08 FF FF 7D DD'
'DD DD DC 77 77 77 70 70 00 00 7D DD DD DD DC FE'
'2C EE C0 84 FE E4 7D DD DD DD DD C2 A2 2E E0 84'
'FF E4 7D DD DD DD DD 2F 8A 22 20 87 77 74 7D DD'
'DD DD DD D2 2F A2 22 78 88 88 7D DD DD DD DD DD'
'D2 22 DD DD DD DD DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD'
}
TSTNVBITS BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 99'
'99 93 39 93 39 99 39 99 93 33 33 99 33 99 39 93'
'39 93 99 33 99 33 33 99 33 99 39 93 39 93 33 99'
'99 33 33 99 33 99 39 93 39 93 99 99 93 33 33 99'
'99 93 39 93 39 93 99 33 99 33 33 99 33 99 39 93'
'99 99 39 99 93 33 33 99 33 99 33 33 39 93 33 33'
'33 33 33 99 99 93 39 93 33 93 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVCOLLECTION BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'99 99 33 39 99 93 39 93 99 33 33 39 93 39 93 99'
'33 99 39 93 99 33 33 99 33 33 93 99 33 99 39 93'
'99 33 33 99 33 33 33 99 33 99 39 93 99 33 33 99'
'33 33 33 99 33 99 39 93 99 33 33 99 33 33 33 39'
'99 93 39 93 99 33 33 39 93 39 93 33 33 33 39 93'
'99 33 33 33 99 99 33 33 33 33 39 93 99 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVDICTIONARY BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 99'
'99 93 39 93 39 99 93 39 99 33 33 99 33 93 39 93'
'99 33 99 39 93 33 33 99 33 99 39 93 99 33 33 39'
'93 33 33 99 33 99 39 93 99 33 33 39 93 33 33 99'
'33 99 39 93 99 33 99 39 93 33 33 99 33 99 39 93'
'39 99 93 99 99 33 33 99 33 93 33 33 33 33 33 39'
'93 33 33 99 99 93 39 93 33 33 33 33 93 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVDQUE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 93 33 33 33 33 33 33 33 33 39'
'99 99 93 33 99 99 33 99 99 93 33 99 39 99 33 39'
'93 99 39 93 39 33 39 93 93 39 93 39 93 99 39 99'
'99 93 39 93 33 39 93 39 93 99 39 93 39 33 39 93'
'33 39 93 39 93 99 39 93 39 33 39 93 33 39 93 39'
'93 99 33 99 93 33 33 99 33 99 33 33 33 33 33 33'
'33 33 33 39 99 93 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVLARRAY BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'99 33 33 99 99 33 99 33 33 33 33 33 39 33 33 93'
'99 33 99 33 33 33 33 33 39 99 99 93 99 33 99 33'
'33 33 33 33 39 93 39 93 99 33 99 33 33 33 33 33'
'33 93 99 33 99 99 99 99 33 33 33 33 33 99 99 33'
'99 99 99 99 33 33 33 33 33 39 93 33 33 33 33 33'
'33 33 33 33 33 39 93 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVLIST BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 39'
'99 99 99 93 39 99 93 39 99 33 33 39 93 33 39 93'
'99 33 99 39 93 33 33 39 93 33 39 93 33 99 99 39'
'93 33 33 39 93 33 39 93 99 99 93 39 93 33 33 39'
'93 33 39 93 99 33 99 39 93 33 33 39 93 33 39 93'
'39 99 93 99 99 33 33 39 93 33 33 33 33 33 33 39'
'93 33 33 39 93 33 39 93 33 33 33 33 93 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVLMATRIX BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 39'
'93 93 99 33 99 99 93 99 93 33 33 39 93 93 99 39'
'93 39 93 99 33 33 33 39 93 93 99 39 93 39 93 99'
'33 33 33 39 99 39 99 33 39 99 93 99 33 33 33 39'
'99 39 99 39 93 39 93 99 33 33 33 39 99 39 99 33'
'99 99 39 99 93 33 33 39 99 39 99 33 33 33 33 99'
'33 33 33 39 99 39 99 33 33 33 33 39 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVSORTEDCOLLECTION BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 99'
'99 33 39 99 93 39 99 93 39 93 33 93 39 93 99 33'
'99 99 33 99 39 93 39 93 39 93 99 33 33 99 33 99'
'39 93 33 39 99 93 99 33 33 99 33 99 39 93 33 99'
'93 33 99 33 99 99 33 99 39 93 33 93 33 33 39 99'
'93 39 99 93 39 93 33 93 39 93 33 33 33 33 33 33'
'39 93 33 99 99 33 33 33 33 33 33 33 39 93 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTNVTREE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 39'
'93 33 99 33 39 99 99 39 99 99 33 39 93 33 99 33'
'99 33 93 99 33 93 33 39 93 33 99 33 99 99 99 99'
'99 99 33 39 93 33 99 33 99 33 93 99 33 93 33 39'
'93 33 99 99 99 33 93 99 33 93 33 39 93 33 99 99'
'39 99 33 39 99 33 33 39 93 33 33 33 33 33 33 33'
'33 33 39 99 99 99 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 FF FF FF FF FF FF FF FF 33'
'33 33 30 00 00 00 00 00 00 00 0F 33 33 33 30 F3'
'33 33 33 33 33 33 0F 33 33 33 30 F3 00 03 30 33'
'00 03 0F 33 33 33 30 F3 33 03 30 33 03 33 0F 33'
'33 33 30 F3 00 03 30 33 03 33 0F 33 33 33 30 F3'
'03 33 30 33 03 33 0F 33 33 33 30 F3 00 03 00 03'
'00 03 0F 33 33 33 30 F3 33 33 33 33 33 33 0F 33'
'33 33 30 FF FF FF FF FF FF FF 0F 33 33 33 30 00'
'00 00 00 00 00 00 03 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
LANGUAGE LANG_ENGLISH,SUBLANG_ENGLISH_US
TSTPDF417BARCODE BITMAP LOADONCALL MOVEABLE DISCARDABLE IMPURE
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 00 30 00 30 00 03 30 03 00 00 03 03 00 30'
'00 30 00 03 30 03 00 00 03 03 00 30 00 30 00 03'
'30 03 00 00 03 03 00 30 00 03 03 30 30 00 30 30'
'03 03 00 30 00 03 03 30 30 00 30 30 03 03 00 30'
'00 03 03 30 30 00 30 30 03 03 00 30 30 33 00 30'
'00 30 00 30 03 03 00 30 30 33 00 30 00 30 00 30'
'03 03 00 30 30 33 00 30 00 30 00 30 03 03 00 30'
'30 03 03 03 00 00 03 30 03 03 00 30 30 03 03 03'
'00 00 03 30 03 03 00 30 30 03 03 03 00 00 03 30'
'03 03 00 30 00 33 00 00 30 00 33 30 03 03 00 30'
'00 33 00 00 30 00 33 30 03 03 00 30 00 33 00 00'
'30 00 33 30 03 03 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
LANGUAGE LANG_NEUTRAL,SUBLANG_NEUTRAL
TSTPNBARCODE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD 77 77 77 77 77 77 7D DD DD DD DD'
'DD 78 88 88 88 88 88 7D DD DD DD DD DD 73 88 83'
'33 88 83 7D DD DD DD DD DD 7B 38 30 00 38 38 7D'
'DD DD DD DD DD 7F F3 0F FB 03 88 7D DD DD DD DD'
'DD 7B 80 FB FF F0 38 7D DD DD DD DD DD 78 0B FF'
'FB FF 03 7D DD DD DD DD DD 70 FF FB FF FB F0 7D'
'DD DD DD DD DD 7F FB FF FB FF FB 0D DD DD DD DD'
'DD 77 77 77 77 77 77 7D DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD'
'DD DD D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 DD D0 D0'
'D0 D0 D0 D0 D0 D0 D0 D0 D0 DD D0 D0 D0 D0 D0 D0'
'D0 D0 D0 D0 D0 DD D0 D0 D0 D0 D0 D0 D0 D0 D0 D0'
'D0 DD D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 D0 DD D0 DD'
'DD D0 D0 DD DD DD D0 DD D0 DD D0 DD DD D0 D0 DD'
'DD DD D0 DD D0 DD D0 DD DD D0 D0 DD DD DD D0 DD'
'D0 DD D0 DD DD D0 D0 DD DD DD D0 DD D0 DD DD DD'
'DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD'
}
TSTREGEX BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 30 00 03 33 33 33'
'33 33 33 30 00 03 30 33 33 33 33 33 33 33 33 33'
'33 03 30 33 33 33 33 33 33 33 33 33 33 03 30 33'
'33 33 30 00 03 33 00 00 33 03 30 33 33 33 30 33'
'03 33 30 33 33 03 30 33 33 33 33 00 03 00 30 33'
'33 03 30 33 33 33 33 33 03 33 33 03 33 03 30 33'
'33 33 30 00 03 33 00 00 33 03 30 33 33 33 33 33'
'33 33 33 33 33 03 30 33 33 33 33 33 33 33 33 33'
'33 03 30 33 33 33 33 33 33 33 33 33 33 03 30 33'
'30 33 30 33 33 33 33 33 33 03 30 33 33 03 03 33'
'33 33 33 33 33 03 30 33 33 30 33 33 33 33 33 33'
'33 03 30 00 03 33 33 33 33 33 33 30 00 03 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTSPAWNAPPLICATION BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 DD DD DD DD DD DD DD DD DD DD'
'DD DD D0 00 00 00 00 00 00 0D DD DD DD DD D0 B8'
'B8 B8 B8 B8 B8 0D DD DD DD DD D0 8C CC CB 8C CC'
'CB 0D DD DD DD DD D0 B8 B8 B8 B8 B8 B8 0D DD DD'
'DD DD D0 8C CC CB 8C CC CB 0D 77 77 77 DD D0 B8'
'B8 B8 B8 B8 B8 00 00 00 07 7D D0 00 00 00 00 00'
'00 0D DD DD D0 7D D0 80 44 44 44 08 08 0D DD DD'
'D0 7D D0 00 00 00 00 00 00 0D DD DD D0 7D DD DD'
'DD DD DD DD DD DD DD DD D0 7D DD DD DD DD DD DD'
'DD DD DD DD D0 7D D0 00 00 00 00 00 00 0D DD DD'
'D0 7D D0 B8 B8 B8 B8 B8 B8 0D DD DD D0 7D D0 8C'
'CC CB 8C CC CB 0D DD D7 D0 7D D0 B8 B8 B8 B8 B8'
'B8 0D DD 07 D0 7D D0 8C CC CB 8C CC CB 0D D0 07'
'70 DD D0 B8 B8 B8 B8 B8 B8 0D 00 00 0D DD D0 8C'
'CC CB 8C CC CB 0D D0 07 DD DD D0 B8 B8 B8 B8 B8'
'B8 0D DD 0D DD DD D0 00 00 00 00 00 00 0D DD DD'
'DD DD D0 80 44 44 44 08 08 0D DD DD DD DD D0 00'
'00 00 00 00 00 0D DD DD DD DD DD DD DD DD DD DD'
'DD DD DD DD DD DD'
}
TSTVERSIONINFO BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 88 88 88 88 88 88 88 88 88 88'
'88 88 88 88 88 88 80 00 88 08 00 80 00 08 88 88'
'88 88 80 80 88 08 00 88 08 88 88 88 88 88 80 80'
'88 08 88 88 80 88 88 88 88 88 80 80 88 08 88 88'
'88 08 88 88 88 88 80 80 80 08 88 80 88 08 88 88'
'88 88 88 88 88 08 88 88 00 08 88 88 88 88 88 88'
'88 88 88 88 88 88 88 88 80 00 00 08 88 88 88 88'
'88 88 88 88 80 BF BF 00 00 00 88 88 88 88 88 88'
'80 FB FB 0F FF F0 88 88 88 88 88 88 80 BF BF 0F'
'FF F0 88 88 88 88 88 80 00 FB 00 0F FF F0 88 88'
'88 88 88 80 B0 BF 0F 0F FF F0 88 88 88 88 88 80'
'F0 00 00 FF FF F0 88 88 88 88 88 80 BF BF 0F FF'
'FF F0 88 88 88 88 80 00 FB 00 0F FF FF F0 88 88'
'88 88 80 B0 BF 0F 0F FF 00 00 88 88 88 88 80 F0'
'00 00 FF FF 0F 08 88 88 88 88 80 BF BF 0F FF FF'
'00 88 88 88 88 88 80 FB 00 00 00 00 08 88 88 88'
'88 88 80 BF 0F 08 88 88 88 88 88 88 88 88 80 00'
'00 88 88 88 88 88 88 88 88 88 88 88 88 88 88 88'
'88 88 88 88 88 88'
}
TSTWMDATACOPY BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 44 44 44 44 43 33 33'
'33 33 33 33 33 4F FF FF FF 43 33 33 33 33 33 33'
'33 4F 00 00 0F 43 33 33 33 33 00 00 00 4F FF FF'
'FF 43 33 33 33 33 0F FF FF 4F 00 00 0F 43 33 33'
'33 33 0F 00 00 4F FF FF FF 43 33 33 33 33 0F FF'
'FF 4F 00 F4 44 43 33 33 33 33 0F 00 00 4F FF F4'
'F4 33 33 33 33 33 0F FF FF 4F FF F4 43 33 33 33'
'33 33 0F 00 F0 44 44 44 33 33 33 33 33 33 0F FF'
'F0 F0 33 33 33 33 33 33 33 33 0F FF F0 03 33 33'
'33 33 33 33 33 33 00 00 00 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 03 03 30 30 30'
'33 33 33 33 33 33 33 03 03 30 30 30 33 33 33 33'
'33 33 33 03 03 30 30 30 33 33 33 33 33 33 30 30'
'30 30 03 00 33 33 33 33 33 33 30 30 30 30 03 00'
'33 33 33 33 33 33 30 30 30 30 33 30 33 33 33 33'
'33 33 30 30 30 30 33 30 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
TSTGENERALLOG BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 88 88 88 88 88 88 88 88 88 88'
'88 88 8B 08 88 88 88 84 44 88 88 88 88 88 80 00'
'88 88 88 48 88 48 44 48 48 48 88 00 08 88 88 48'
'88 48 48 88 48 48 88 80 80 88 88 48 84 48 44 48'
'48 48 88 88 0B 08 88 48 88 88 48 48 44 88 88 88'
'80 70 88 48 88 48 44 48 48 88 88 88 88 0B 08 84'
'44 88 88 88 88 88 88 88 88 80 78 88 88 88 88 88'
'88 88 00 00 88 88 80 00 00 88 88 80 00 00 11 11'
'70 00 01 11 11 00 00 71 11 10 1F F8 11 11 11 77'
'71 11 11 18 88 10 1F FF FF FF FF F7 FF FF FF FF'
'FF 10 1F FF FF FF FF F7 FF FF FF FF F1 08 81 FF'
'FF FF FF F7 FF FF FF FF F1 08 81 FF FF FF FF F7'
'FF FF FF FF F1 08 81 0F FF FF F0 F7 FF FF FF FF'
'11 08 81 FF 0F 00 0F F7 FF FF FF FF 10 88 88 10'
'FF FF FF 07 FF FF FF FF 10 88 88 1F F0 F0 FF F7'
'FF FF FF FF 10 88 88 1F 0F FF F0 F7 FF FF FF FF'
'10 88 88 1F FF 0F FF F7 FF FF FF F1 08 88 88 87'
'77 77 77 77 77 77 77 77 88 88 88 88 88 88 88 88'
'88 88 88 88 88 88'
}
TSTNTEVENTLOG BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 88 88 88 88 88 88 88 88 88 88'
'88 88 8B 08 88 88 88 44 48 44 48 84 44 88 80 00'
'88 88 88 84 88 84 88 88 48 88 88 00 08 88 88 84'
'88 44 88 88 48 88 88 80 80 88 88 84 84 84 88 88'
'48 88 88 88 0B 08 88 84 84 84 88 88 48 88 88 88'
'80 70 88 84 48 84 88 48 48 48 88 88 88 0B 08 44'
'48 44 48 44 44 48 88 88 88 80 78 88 88 88 88 88'
'88 88 00 00 88 88 80 00 00 88 88 80 00 00 11 11'
'70 00 01 11 11 00 00 71 11 10 1F F8 11 11 11 77'
'71 11 11 18 88 10 1F FF FF FF FF F7 FF FF FF FF'
'FF 10 1F FF FF FF FF F7 FF FF FF FF F1 08 81 FF'
'FF FF FF F7 FF FF FF FF F1 08 81 FF FF FF FF F7'
'FF FF FF FF F1 08 81 0F FF FF F0 F7 FF FF FF FF'
'11 08 81 FF 0F 00 0F F7 FF FF FF FF 10 88 88 10'
'FF FF FF 07 FF FF FF FF 10 88 88 1F F0 F0 FF F7'
'FF FF FF FF 10 88 88 1F 0F FF F0 F7 FF FF FF FF'
'10 88 88 1F FF 0F FF F7 FF FF FF F1 08 88 88 87'
'77 77 77 77 77 77 77 77 88 88 88 88 88 88 88 88'
'88 88 88 88 88 88'
}
TSTEXCEPTIONLOG BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 88 88 88 88 88 88 88 88 88 88'
'88 88 8B 08 88 88 88 88 88 8B 0B 88 88 88 80 00'
'88 88 88 88 8B B0 00 BB 88 88 88 00 08 88 88 88'
'8B BB BB BB 88 88 88 80 80 88 88 88 BB BB 0B BB'
'B8 88 88 88 0B 08 88 88 BB BB 0B BB B8 88 88 88'
'80 70 88 88 BB B0 00 BB B8 88 88 88 88 0B 08 88'
'8B B0 00 BB 88 88 88 88 88 80 78 88 8B B0 00 BB'
'88 88 00 00 88 88 80 00 88 8B BB 88 88 00 11 11'
'70 00 01 11 11 00 00 71 11 10 1F F8 11 11 11 77'
'71 11 11 18 88 10 1F FF FF FF FF F7 FF FF FF FF'
'FF 10 1F FF FF FF FF F7 FF FF FF FF F1 08 81 FF'
'FF FF FF F7 FF FF FF FF F1 08 81 FF FF FF FF F7'
'FF FF FF FF F1 08 81 0F FF FF F0 F7 FF FF FF FF'
'11 08 81 FF 0F 00 0F F7 FF FF FF FF 10 88 88 10'
'FF FF FF 07 FF FF FF FF 10 88 88 1F F0 F0 FF F7'
'FF FF FF FF 10 88 88 1F 0F FF F0 F7 FF FF FF FF'
'10 88 88 1F FF 0F FF F7 FF FF FF F1 08 88 88 87'
'77 77 77 77 77 77 77 77 88 88 88 88 88 88 88 88'
'88 88 88 88 88 88'
}

67
components/systools/source/design/StRegDb.pas Normal file
View File

@ -0,0 +1,67 @@
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StRegDb.pas 4.04 *}
{*********************************************************}
{* SysTools: Data-Aware Component Registration Unit *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{$R StRegDb.r32}
unit StRegDb;
interface
uses
Classes;
procedure Register;
implementation
uses
StBase,
StDbBarC,
StDbPNBC,
StDb2DBC;
//, StExport;
procedure Register;
begin
RegisterComponents('SysTools', [
TStDbBarCode,
TStDbPNBarCode,
TStDbPDF417Barcode,
TStDbMaxiCodeBarcode
]);
end;
end.

193
components/systools/source/design/StRegDb.rc Normal file
View File

@ -0,0 +1,193 @@
/* ***** 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 ***** */
/****************************************************************************
stregdb.rc
produced by Borland Resource Workshop
*****************************************************************************/
STDBTEMPLATE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 77 77 77 77 77 77 77 73 33 33 33 33 78 7F'
'FF F8 FF FF FF 73 33 33 33 33 7F 7F 88 F8 F8 88'
'8F 73 33 33 33 33 78 7F FF F8 FF FF FF 73 33 33'
'33 33 7F 7F 88 F8 F8 88 FF 73 33 33 33 33 78 7F'
'FF F8 FF FF FF 73 33 33 33 33 7F 7F 88 F8 F8 88'
'8F 73 33 33 33 33 78 7F FF F8 FF FF FF 73 33 33'
'33 33 77 77 77 77 77 77 77 73 33 33 33 33 78 7F'
'88 88 F8 88 88 73 33 33 33 33 77 77 77 77 77 77'
'77 73 33 33 33 33'
}
TSTDBBARCODE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 33 03 33 33 33 33 33 33 33 33'
'30 33 33 03 33 33 33 33 33 33 33 33 30 33 33 03'
'03 00 30 30 33 00 30 30 30 33 33 03 03 00 30 30'
'33 00 30 30 30 33 33 03 03 00 30 30 33 00 30 30'
'30 33 33 03 03 00 30 30 33 00 30 30 30 33 33 03'
'03 00 30 30 33 00 30 30 30 33 33 03 03 00 30 30'
'33 00 30 30 30 33 33 03 03 00 30 30 33 00 30 30'
'30 33 77 07 07 00 70 70 77 00 30 30 30 33 78 0F'
'0F 00 F0 F0 FF 00 30 30 30 33 7F 0F 08 00 F0 80'
'8F 00 30 30 30 33 78 0F 0F 00 F0 F0 FF 00 30 30'
'30 33 7F 0F 08 00 F0 80 FF 00 30 30 30 33 78 0F'
'0F 00 F0 F0 FF 00 30 30 30 33 7F 0F 88 F8 F8 88'
'8F 73 33 33 30 33 78 0F FF F8 FF FF FF 73 33 33'
'30 33 77 77 77 77 77 77 77 73 33 33 33 33 78 7F'
'88 88 F8 88 88 73 33 33 33 33 77 77 77 77 77 77'
'77 73 33 33 33 33'
}
LANGUAGE LANG_ENGLISH,SUBLANG_ENGLISH_US
TSTDBMAXICODEBARCODE BITMAP LOADONCALL MOVEABLE DISCARDABLE IMPURE
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33 03 33 03 33 33 33 30 33 33 33'
'33 30 00 30 00 33 33 33 00 03 33 33 33 33 03 33'
'03 33 33 33 30 33 33 33 33 03 33 33 33 33 33 03'
'33 33 33 33 30 00 33 33 30 03 30 00 33 33 33 33'
'33 03 33 30 03 30 03 03 30 33 77 77 77 77 77 07'
'77 77 70 33 00 03 7F 7F FF FF F7 0F F0 0F 70 33'
'30 33 7F 7F 88 88 F0 F8 08 80 73 03 33 33 7F 7F'
'FF 0F F0 FF 0F F0 73 03 33 03 7F 7F 80 00 F7 08'
'80 0F 70 33 30 00 7F 7F FF 0F F7 0F FF FF 70 33'
'33 03 7F 7F 88 88 07 F0 08 80 03 33 03 33 7F 7F'
'FF F0 00 FF F0 0F 73 30 00 33 7F 7F 88 88 07 F8'
'88 8F 73 33 03 33 7F 7F FF 0F F7 FF FF 0F 73 03'
'33 03 7F 7F 80 00 F7 F8 80 00 70 00 30 00 7F 7F'
'FF 0F F7 FF FF 0F 73 03 33 03 7F 7F 88 88 F7 F8'
'88 8F 73 33 33 33 7F 7F FF FF F7 FF FF FF 73 33'
'33 33 77 77 77 77 77 77 77 77 73 33 33 33 7F 7F'
'FF FF FF FF FF FF 73 33 33 33 77 77 77 77 77 77'
'77 77 73 33 33 33'
}
TSTDBPDF417BARCODE BITMAP LOADONCALL MOVEABLE DISCARDABLE IMPURE
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 30 03 00 03 00 00 33 00 30 00 00 30 30 03'
'00 03 00 00 33 00 30 00 00 30 30 03 00 03 00 00'
'33 00 30 00 00 30 30 03 00 00 30 33 03 00 03 03'
'00 30 30 03 00 00 30 33 03 00 03 03 00 30 30 03'
'00 00 30 33 03 00 03 03 00 30 30 03 03 03 30 03'
'00 03 00 03 00 30 30 03 03 03 30 03 00 03 00 03'
'00 30 70 07 07 07 70 07 00 07 00 03 00 30 70 0F'
'0F 00 70 F0 F0 00 00 33 00 30 70 0F 08 00 70 80'
'80 00 00 33 00 30 70 0F 0F 00 70 F0 F0 00 00 33'
'00 30 70 0F 00 0F 70 00 0F 00 03 33 00 30 70 0F'
'00 0F 70 00 08 00 03 33 00 30 70 0F 00 0F 70 00'
'0F 00 03 33 00 30 7F 7F 88 8F 7F 88 88 F7 33 33'
'33 33 7F 7F FF FF 7F FF FF F7 33 33 33 33 7F 7F'
'88 8F 7F 88 88 F7 33 33 33 33 7F 7F FF FF 7F FF'
'FF F7 33 33 33 33 77 77 77 77 77 77 77 77 33 33'
'33 33 7F 7F FF FF FF FF FF F7 33 33 33 33 77 77'
'77 77 77 77 77 77 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 33'
}
LANGUAGE LANG_NEUTRAL,SUBLANG_NEUTRAL
TSTDBPNBARCODE BITMAP
{
'42 4D 96 01 00 00 00 00 00 00 76 00 00 00 28 00'
'00 00 18 00 00 00 18 00 00 00 01 00 04 00 00 00'
'00 00 20 01 00 00 00 00 00 00 00 00 00 00 00 00'
'00 00 00 00 00 00 00 00 00 00 00 00 80 00 00 80'
'00 00 00 80 80 00 80 00 00 00 80 00 80 00 80 80'
'00 00 80 80 80 00 C0 C0 C0 00 00 00 FF 00 00 FF'
'00 00 00 FF FF 00 FF 00 00 00 FF 00 FF 00 FF FF'
'00 00 FF FF FF 00 33 33 33 33 33 33 33 33 33 33'
'33 33 33 33 33 77 77 77 77 77 77 73 33 33 33 33'
'33 78 88 88 88 88 88 73 33 33 33 33 33 73 88 83'
'33 88 83 73 33 33 33 33 33 7B 38 30 00 38 38 73'
'33 33 33 33 33 7F F3 0F FB 03 88 73 33 33 33 33'
'33 7B 80 FB FF F0 38 73 33 33 33 33 33 78 0B FF'
'FB FF 03 73 33 33 33 33 33 70 FF FB FF FB F0 73'
'33 33 33 33 33 7F FB FF FB FF FB 03 33 33 33 33'
'33 77 77 77 77 77 77 73 33 33 30 30 30 30 30 30'
'30 30 30 30 30 33 30 30 30 30 30 30 30 30 30 30'
'30 33 70 70 70 70 70 70 70 70 30 30 30 33 70 70'
'F0 F0 F0 F0 F0 70 30 30 30 33 70 70 80 F0 F0 80'
'80 70 30 30 30 33 70 70 F0 F0 F0 F0 F0 70 30 30'
'30 33 7F 7F 80 F0 F8 88 FF 70 33 33 30 33 78 7F'
'F0 F0 FF FF FF 70 33 33 30 33 7F 7F 80 F0 F8 88'
'8F 70 33 33 30 33 78 7F F0 F0 FF FF FF 70 33 33'
'30 33 77 77 70 70 77 77 77 70 33 33 30 33 78 7F'
'88 88 F8 88 88 73 33 33 33 33 77 77 77 77 77 77'
'77 73 33 33 33 33'
}

BIN
components/systools/source/design/streg.r32 Normal file
View File

Binary file not shown.

BIN
components/systools/source/design/stregdb.r32 Normal file
View File

Binary file not shown.

233
components/systools/source/include/StDefine.inc Normal file
View File

@ -0,0 +1,233 @@
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDefine.inc 4.03 *}
{*********************************************************}
{* SysTools: Compiler options/directives include file *}
{*********************************************************}
{ Because StDefine.inc is included in all SysTools units, you can specify }
{ global compiler options here. STDEFINE is included *before* each units' }
{ required compiler options, so options specified here might be overridden }
{ by hardcoded options in the source file. }
{$IFNDEF LINUX}
{---Global compiler defines for 32-bit OS's---}
{$A+} {Word Align Data}
{$H+} {Huge string support}
{$Q+} {Overflow check}
{$R+} {Range check}
{$S-} {Stack check}
{$T-} {Typed @ check}
{$V-} {Var strings}
{$B-} {Incomplete boolean evaluation}
{$J+} {Writeable Typed Constants}
{$ENDIF LINUX}
{$DEFINE ThreadSafe}
{ This define determines whether SysTools operations are safe in a 32-bit }
{ multi-threaded application. Leaving it undefined will improved performance}
{ slightly in a single-threaded 32-bit application. }
{$DEFINE Median}
{.$DEFINE MidPoint}
{.$DEFINE Random}
{ The three partitioning methods used by the merge sort algorithm in STSORT.}
{ Choose one, and one only. Median is on average fastest, and quite safe. }
{ Midpoint is the simplest, but may degrade on some data sets. Random is }
{ the safest, but on average the slowest. Safety in this context means the }
{ prevention of the underlying quicksort degenerating into a sort of O(N^2) }
{ The default is Median. }
{.$DEFINE SuppressWarnings}
{ This define enables you to suppress warnings that are generated for code }
{ in SysTools by Delphi 2/3. The two most common warnings are (a) function }
{ does not set Result and (b) variable used before being initialized. The }
{ code however has been tested to be correct but is complex enough to fool }
{ the compiler. You should leave this define activated. }
{.$DEFINE UseMathUnit}
{ This define is used to decide if the Math unit should be used. }
{ Define UseMathUnit if the Math unit is available (it isn't with some }
{ versions of the compilers -- Delphi 1, C++Builder 1, Delphi 2 Standard, }
{ and a few others - check to be sure). }
{$IFDEF FPC}
{$UNDEF VER80}
{$UNDEF VER90}
{$UNDEF VER93}
{$UNDEF VER100}
{$UNDEF VER110}
{$UNDEF VER120}
{$UNDEF VER125}
{$UNDEF VER130}
{$UNDEF VER135}
{$UNDEF VER140}
{$DEFINE DELPHIXE2}
{$DEFINE HasLongWord}
{$DEFINE HasInt64}
{$ENDIF}
{===========!! DO NOT ALTER ANYTHING BEYOND THIS POINT !!==================}
{===========!! DO NOT ALTER ANYTHING BEYOND THIS POINT !!==================}
{$IFDEF VER93}
{$DEFINE CBuilder}
{$ENDIF}
{$IFDEF VER110}
{$DEFINE CBuilder}
{$ObjExportAll On}
{$ENDIF}
{$IFDEF VER125}
{$DEFINE CBuilder}
{$ObjExportAll On}
{$ENDIF}
{$IFDEF VER130}
{$IFDEF BCB}
{$DEFINE CBuilder}
{$ObjExportAll On}
{$ENDIF}
{$ENDIF}
{$IFDEF VER140}
{$IFDEF BCB}
{$DEFINE CBuilder}
{$ObjExportAll On}
{$ENDIF}
{$ENDIF}
{$IFNDEF LINUX}
{$IFNDEF WIN32}
{$IFDEF VER80}
{$DEFINE WIN16} { Delphi 1.0, 16-Bit Windows }
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFNDEF VER80} {Delphi 1.0}
{$DEFINE VERSION2} {Delphi 2.0 and BCB 1 or higher}
{$ENDIF}
{$IFDEF VERSION2}
{$IFNDEF VER90} {Delphi 2.0}
{$IFNDEF VER93} {BCB 1.0}
{$DEFINE VERSION3} {Delphi 3.0 or BCB 3.0}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFDEF VERSION3}
{$IFNDEF VER100} {Delphi 3}
{$IFNDEF VER110} {BCB 3}
{$DEFINE VERSION4} {Delphi 4.0 or higher}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFDEF VERSION4}
{$IFNDEF VER120} {Delphi 4}
{$IFNDEF VER125} {BCB 4}
{$DEFINE VERSION5} {Delphi 5.0 or higher}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFDEF VERSION5}
{$IFNDEF VER130} { Delphi 5 }
{$IFNDEF VER135} { BCB 5 }
{$IFNDEF LINUX }
{$DEFINE VERSION6} { Delphi 6.0 or higher }
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFDEF VERSION6}
{$IFNDEF VER140} { Delphi 6 }
{$IFNDEF LINUX }
{$DEFINE VERSION7} { Delphi 7.0 or higher }
{$ENDIF}
{$ENDIF}
{$ENDIF}
(*
{$IF compilerversion >= 23} { Delphi XE2 }
{$DEFINE DELPHIXE2}
{$IFEND}
*)
{$IFDEF VERSION4}
{$DEFINE HasLongWord} { D4 and above have a true LongWord type }
{$DEFINE HasInt64 } { D4 and above have a 64-bit Integer }
{$ENDIF}
{$IFDEF LINUX}
{$DEFINE HasLongWord} { Kylix has a true LongWord type }
{$DEFINE HasInt64 } { Kylix has a 64-bit Integer }
{$ENDIF}
{$IFDEF VERSION3}
{$IFNDEF VERSION4}
{$DEFINE VERSION3ONLY}
{$ENDIF}
{$ENDIF}
{Set up the string type expected}
{$UNDEF HStrings}
{$UNDEF WStrings}
{$IFOPT H+}
{$DEFINE HStrings} {Huge strings under WIN32}
{$UNDEF NStrings}
{$ELSE}
{$DEFINE WStrings} {255-character strings under WIN32}
{$UNDEF NStrings}
{$ENDIF}
{$IFDEF Median}
{$IFDEF MidPoint}
!! ERROR: you must define only one of Median, MidPoint, Random
{$ENDIF}
{$IFDEF Random}
!! ERROR: you must define only one of Median, MidPoint, Random
{$ENDIF}
{$ENDIF}
{$IFDEF MidPoint}
{$IFDEF Random}
!! ERROR: you must define only one of Median, MidPoint, Random
{$ENDIF}
{$ENDIF}
{$IFNDEF Median}
{$IFNDEF MidPoint}
{$IFNDEF Random}
!! ERROR: you must define at least one of Median, MidPoint, Random
{$ENDIF}
{$ENDIF}
{$ENDIF}

1520
components/systools/source/run/StBase.pas Normal file
View File

File diff suppressed because it is too large Load Diff

5254
components/systools/source/run/st2dbarc.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2471
components/systools/source/run/stbarc.pas Normal file
View File

File diff suppressed because it is too large Load Diff

649
components/systools/source/run/stbarpn.pas Normal file
View File

@ -0,0 +1,649 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StBarPN.pas 4.04 *}
{*********************************************************}
{* SysTools: PostNet Bar Code component *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit StBarPN;
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType,
{$ELSE}
Windows, Messages,
{$ENDIF}
Classes, ClipBrd, Controls, Graphics, SysUtils,
StBase, StConst, StStrL;
type
TStPNBarCodeDims = packed record
PixPerBar : Longint;
PixPerSpace : Longint;
ShortBarHeight : Longint;
TallBarHeight : Longint;
Width : Longint;
Height : Longint;
end;
TStPNBarCodeRes = packed record
XRes : Longint;
YRes : Longint;
end;
TStPNBarCode = class(TGraphicControl)
protected {private}
{property variables}
FPostalCode : string;
FCheckNumber : Integer;
{internal variables}
pnbcDisplayDims : TStPNBarCodeDims;
pnbcDefRes : TStPNBarCodeRes;
{property methods}
function GetVersion : string;
procedure SetPostalCode(Value : String);
procedure SetVersion (const v : string);
{internal methods}
function DrawTallBar(C : TCanvas;
Dims : TStPNBarCodeDims;
XPos : Integer;
AddSpace : Boolean) : Longint;
function DrawShortBar(C : TCanvas;
Dims : TStPNBarCodeDims;
XPos : Integer;
AddSpace : Boolean) : Longint;
function DrawNumber(C : TCanvas;
Dims : TStPNBarCodeDims;
Value : Integer;
XPos : Longint;
FrontGuard : Boolean;
EndGuard : Boolean) : Longint;
procedure DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
procedure SetCheckNumber;
(*
procedure CMTextChanged(var Msg : TMessage);
message CM_TEXTCHANGED;
*)
protected
procedure Loaded; override;
procedure Paint; override;
public
constructor Create(AOwner : TComponent); override;
procedure ComputeSizes(C : TCanvas;
Res : TStPNBarCodeRes;
var Dims : TStPNBarCodeDims);
procedure CopyToClipboard;
procedure PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
procedure PaintToDC(DC : hDC; Position : TPoint);
procedure PaintToPrinterCanvas(ACanvas : TCanvas; Position : TPoint);
procedure PaintToPrinterDC(DC : hDC; Position : TPoint);
procedure SaveToFile(ACanvas : TCanvas; const FileName : string);
procedure SaveToFileRes(Res : TStPNBarCodeRes; const FileName : string);
published
{properties}
property Cursor;
property Enabled;
property Hint;
property ParentShowHint;
property ShowHint;
property Visible;
property PostalCode : string read FPostalCode write SetPostalCode;
property Version : string read GetVersion write SetVersion stored False;
{events}
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
implementation
{$IFDEF FPC}
uses
Dialogs;
{$ENDIF}
{*** TStPNBarCode ***}
function TStPNBarCode.GetVersion : string;
begin
Result := StVersionStr;
end;
procedure TStPNBarCode.SetVersion(const v : string);
begin
end;
constructor TStPNBarCode.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
{defaults}
pnbcDefRes.XRes := 0;
pnbcDefRes.YRes := 0;
{set arbitrary values for height/width so that component automatically resizes}
Height := 10;
Width := 10;
PostalCode := '12345';
SetCheckNumber;
end;
procedure TStPNBarCode.Loaded;
begin
inherited Loaded;
Invalidate;
end;
procedure TStPNBarCode.Paint;
begin
ComputeSizes(Canvas, pnbcDefRes, pnbcDisplayDims);
Height := pnbcDisplayDims.Height;
Width := pnbcDisplayDims.Width;
DrawBarCode(Canvas, pnbcDisplayDims);
end;
procedure TStPNBarCode.SetCheckNumber;
var
I : Longint;
begin
if (Length(TrimL(FPostalCode)) < 5) then Exit;
FCheckNumber := 0;
for I := 1 to Length(FPostalCode) do
FCheckNumber := FCheckNumber + StrToInt(FPostalCode[I]);
I := FCheckNumber mod 10;
if (I > 0) then
FCheckNumber := 10 - I
else
FCheckNumber := 0;
end;
procedure TStPNBarCode.SetPostalCode(Value : string);
var
I : Integer;
Local : string;
begin
if (csLoading in ComponentState) then Exit;
Local := TrimL(Value);
{strip non-numerics}
I := 1;
repeat
if not (Local[I] in ['0'..'9']) then
System.Delete(Local, I, 1)
else
Inc(I);
until (I > Length(Local));
{ looks like a valid Postal Code?}
if (Local <> FPostalCode) then begin
if (Length(Local) in [5, 9, 11]) then begin
FPostalCode := Local;
SetCheckNumber;
Invalidate;
end else
RaiseStError(EStPNBarCodeError, stscInvalidLength);
end; { else it's the same code, don't bother updating }
end;
function TStPNBarCode.DrawTallBar(C : TCanvas;
Dims : TStPNBarCodeDims;
XPos : Integer;
AddSpace : Boolean) : Longint;
var
YPos : Longint;
begin
Result := XPos;
YPos := Dims.Height - 5 - Dims.TallBarHeight;
C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.TallBarHeight);
Result := Result + Dims.PixPerBar;
if (AddSpace) then
Inc(Result, Dims.PixPerSpace);
end;
function TStPNBarCode.DrawShortBar(C : TCanvas;
Dims : TStPNBarCodeDims;
XPos : Integer;
AddSpace : Boolean) : Longint;
var
YPos : Longint;
begin
Result := XPos;
YPos := Dims.Height - 5 - Dims.ShortBarHeight;
C.Rectangle(XPos, YPos, XPos+Dims.PixPerBar, YPos+Dims.ShortBarHeight);
Result := Result + Dims.PixPerBar;
if (AddSpace) then
Inc(Result, Dims.PixPerSpace);
end;
function TStPNBarCode.DrawNumber(C : TCanvas;
Dims : TStPNBarCodeDims;
Value : Integer;
XPos : Longint;
FrontGuard : Boolean;
EndGuard : Boolean) : Longint;
begin
Result := XPos;
if (FrontGuard) then
Result := DrawTallBar(C, Dims, Result, True);
case Value of
0 : begin
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
end;
1 : begin
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
end;
2 : begin
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
end;
3 : begin
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
end;
4 : begin
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
end;
5 : begin
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
end;
6 : begin
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
end;
7 : begin
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
end;
8 : begin
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
end;
9 : begin
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawTallBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
Result := DrawShortBar(C, Dims, Result, True);
end;
end;
if (EndGuard) then
Result := DrawTallBar(C, Dims, Result, False);
end;
procedure TStPNBarCode.ComputeSizes(C : TCanvas;
Res : TStPNBarCodeRes;
var Dims : TStPNBarCodeDims);
var
PPIX,
PPIY : Longint;
begin
if csLoading in ComponentState then
Exit;
{get resolution}
if ((Res.XRes > 0) and (Res.YRes > 0)) then begin
PPIX := Res.XRes;
PPIY := Res.YRes;
end else begin
PPIX := GetDeviceCaps(C.Handle, LOGPIXELSX);
PPIY := GetDeviceCaps(C.Handle, LOGPIXELSY);
end;
{PN bar is 0.015" to 0.025" - use mid value}
{add 1 since Canvas.Rectangle draws 1 pixel less than Width}
Dims.PixPerBar := Round(PPIX * 0.017) + 1;
{CenterLine distance is 0.0416" to 0.0500". Space is that minus width of bar}
{In all cases the Pitch must be 22 +/-2 bars/Inch where a bar is the bar and}
{the trailing space}
{add 1 since Canvas.Rectangle draws 1 pixel less than Width}
Dims.PixPerSpace := Round(0.0475 * PPIX) - Dims.PixPerBar + 1;
{max height of short bar is 0.050" +/-0.010". To allow for 75dpi, go a}
{little less}
{add 1 since Canvas.Rectangle draws 1 pixel less than Height}
Dims.ShortBarHeight := Round(0.047 * PPIY) + 1;
{max height of tall bar is 0.125" +/-0.010". To allow for 75dpi, go a}
{little less}
{add 1 since Canvas.Rectangle draws 1 pixel less than Height}
Dims.TallBarHeight := Round(0.122 * PPIY) + 1;
{Total Width of Canvas =
FrontGuardBar + Space +
(NumberChars + CheckChar) * (5 * (PixelsPerBar + PixelsPerSpace)) +
(EndBar w/o Space) +
5 pixels left/right margin
}
Dims.Width :=
(Dims.PixPerBar + Dims.PixPerSpace) +
(Length(PostalCode) + 1) * (5 * (Dims.PixPerBar + Dims.PixPerSpace)) +
Dims.PixPerBar + 10;
{Height = Height of tall bar + 3 pixel top/bottom margin}
Dims.Height := Dims.TallBarHeight + 3;
end;
procedure TStPNBarCode.DrawBarCode(C : TCanvas; Dims : TStPNBarCodeDims);
var
I,
XPos : Longint;
begin
if csLoading in ComponentState then
Exit;
C.Brush.Color := clBlack;
C.Brush.Style := bsSolid;
{Draw the Code}
XPos := 5;
XPos := DrawNumber(C, Dims, StrToInt(PostalCode[1]), XPos, True, False);
for I := 2 to Length(PostalCode) do
XPos := DrawNumber(C, Dims, StrToInt(PostalCode[I]), XPos, False, False);
DrawNumber(C, Dims, FCheckNumber, XPos, False, True);
end;
(*
procedure TStPNBarCode.CMTextChanged(var Msg : TMessage);
begin
SetCheckNumber;
Invalidate;
end;
*)
procedure TStPNBarCode.CopyToClipboard;
var
{$IFNDEF FPC}
MetaFile : TMetaFile;
MetaFileCanvas : TMetaFileCanvas;
{$ENDIF}
Bitmap : TBitmap;
Dims : TStPNBarCodeDims;
begin
Clipboard.Clear;
Clipboard.Open;
try
{bitmap}
Bitmap := TBitmap.Create;
try
ComputeSizes(Bitmap.Canvas, pnbcDefRes, Dims);
Bitmap.Width := Dims.Width;
Bitmap.Height := Dims.Height;
DrawBarCode(Bitmap.Canvas, Dims);
Clipboard.Assign(Bitmap);
{$IFNDEF FPC}
{metafile}
MetaFile := TMetaFile.Create;
try
MetaFileCanvas := TMetaFileCanvas.Create(MetaFile, 0);
try
MetaFile.Enhanced := True;
MetaFile.Width := ClientWidth;
MetaFile.Height := ClientHeight;
MetaFileCanvas.Draw(0, 0, Bitmap);
finally
MetaFileCanvas.Free;
end;
Clipboard.Assign(MetaFile);
finally
MetaFile.Free;
end;
{$ENDIF}
finally
Bitmap.Free;
end
finally
Clipboard.Close;
end;
end;
procedure TStPNBarCode.PaintToDC(DC : hDC; Position : TPoint);
var
Bmp : TBitmap;
ACanvas : TCanvas;
Dims : TStPNBarCodeDims;
R1,
R2 : TRect;
begin
ACanvas := TCanvas.Create;
ACanvas.Handle := DC;
Bmp := TBitmap.Create;
try
ComputeSizes(ACanvas, pnbcDefRes, Dims);
Bmp.Height := Dims.Height;
Bmp.Width := Dims.Width;
R1 := Rect(0, 0, Dims.Width, Dims.Height);
R2 := Rect(Position.X, Position.Y,
Dims.Width + Position.X,
Dims.Height + Position.Y);
DrawBarCode(Bmp.Canvas, Dims);
ACanvas.CopyRect(R2, Bmp.Canvas, R1);
finally
Bmp.Free;
ACanvas.Free;
end;
end;
procedure TStPNBarCode.PaintToCanvas(ACanvas : TCanvas; Position : TPoint);
begin
PaintToDC(ACanvas.Handle, Position);
end;
procedure TStPNBarCode.PaintToPrinterCanvas(ACanvas : TCanvas;
Position : TPoint);
begin
PaintToPrinterDC(ACanvas.Handle, Position);
end;
procedure TStPNBarCode.PaintToPrinterDC(DC : hDC; Position : TPoint);
var
Bmp : TBitmap;
ACanvas : TCanvas;
Dims : TStPNBarCodeDims;
R1,
R2 : TRect;
Info : PBitMapInfo;
InfoSize : DWORD;
ImageSize : DWORD;
Image : Pointer;
begin
{$IFDEF FPC}
// FIX ME
ShowMessage('This function is not yet implemented.');
{$ELSE}
ACanvas := TCanvas.Create;
Bmp := TBitmap.Create;
ACanvas.Handle := DC;
try
ComputeSizes(ACanvas, pnbcDefRes, Dims);
Bmp.Height := Dims.Height;
Bmp.Width := Dims.Width;
R1 := Rect(0, 0, Dims.Width, Dims.Height);
R2 := Rect(Position.X, Position.Y,
Dims.Width + Position.X,
Dims.Height + Position.Y);
DrawBarCode(Bmp.Canvas, Dims);
{Delphi does not allow a simple Canvas.CopyRect to the printer Canvas}
with Bmp do begin
GetDIBSizes(Handle, InfoSize, ImageSize);
GetMem(Info, InfoSize);
try
GetMem(Image, ImageSize);
try
GetDIB(Handle, Palette, Info^, Image^);
with Info^.bmiHeader do begin
StretchDIBits(ACanvas.Handle,
R2.Left, R2.Top, Dims.Width, Dims.Height,
0, 0, biWidth, biHeight,
Image, Info^, DIB_RGB_COLORS, SRCCOPY);
end;
finally
FreeMem(Image, ImageSize)
end;
finally
FreeMem(Info, InfoSize);
end;
end;
finally
Bmp.Free;
ACanvas.Free;
end;
{$ENDIF}
end;
procedure TStPNBarCode.SaveToFile(ACanvas : TCanvas;
const FileName : string);
var
Bmp : TBitmap;
Dims : TStPNBarCodeDims;
begin
Bmp := TBitmap.Create;
try
ComputeSizes(ACanvas, pnbcDefRes, Dims);
Bmp.Height := Dims.Height;
Bmp.Width := Dims.Width;
DrawBarCode(Bmp.Canvas, Dims);
Bmp.SaveToFile(FileName);
finally
Bmp.Free;
end;
end;
procedure TStPNBarCode.SaveToFileRes(Res : TStPNBarCodeRes;
const FileName : string);
var
Bmp : TBitmap;
Dims : TStPNBarCodeDims;
begin
Bmp := TBitmap.Create;
try
ComputeSizes(Bmp.Canvas, Res, Dims);
Bmp.Height := Dims.Height;
Bmp.Width := Dims.Width;
DrawBarCode(Bmp.Canvas, Dims);
Bmp.SaveToFile(FileName);
finally
Bmp.Free;
end;
end;
end.

315
components/systools/source/run/stccy.dat Normal file
View File

@ -0,0 +1,315 @@
; World Currency Information
; ISO 4217-style currency information
; Format:
;[ISOCode]
;ISOName=<ISO 4217 3 Letter Currency ID>
;ISOCode=<ISO 4217 3 Digit Currency Number>
;UnitMajor=<Major Currency Name>
;UnitMinor=<Minor Currency Name>
;Ratio=<ratio of minor currency to major>
;Name=<Country-Currency Name>
[AUD]
ISOName=AUD
ISOCode=036
UnitMajor=dollar
UnitMinor=cent
Ratio=100
Name=Australian Dollar
[ATS]
ISOName=ATS
ISOCode=040
UnitMajor=schilling
UnitMinor=groschen
Ratio=100
Name=Austrian Schilling
[BEF]
ISOName=BEF
ISOCode=056
UnitMajor=franc
Ratio=100
UnitMinor=
Name=Belgium Franc
[BRL]
ISOName=BRL
ISOCode=986
UnitMajor=real
UnitMinor=centavo
Ratio=100
Name=Brazilian Real
[CAD]
ISOName=CAD
ISOCode=124
UnitMajor=dollar
UnitMinor=cent
Ratio=100
Name=Canadian Dollar
[CNY]
ISOName=CNY
ISOCode=156
UnitMajor=yuan renminbi
UnitMinor=jiao
Ratio=100
Name=Chinese Renminbi Yuan
[DKK]
ISOName=DKK
ISOCode=208
UnitMajor=krone
UnitMinor=�re
Ratio=100
Name=Danish Krone
[DEM]
ISOName=DEM
ISOCode=276
UnitMajor=deutsche mark
UnitMinor=pfennig
Ratio=100
Name=Deutsche Mark
[NLG]
ISOName=NLG
ISOCode=528
UnitMajor=gulden
UnitMinor=cent
Ratio=100
Name=Dutch Guilder
[EGP]
ISOName=EGP
ISOCode=818
UnitMajor=pound
UnitMinor=piaster
Ratio=100
Name=Egytian Pound
[EUR]
ISOName=EUR
ISOCode=978
UnitMajor=Euro
UnitMinor=euro-cent
Ratio=100
Name=Euro
[FRF]
ISOName=FRF
ISOCode=250
UnitMajor=franc
UnitMinor=centime
Ratio=100
Name=French Franc
[GRD]
ISOName=GRD
ISOCode=300
UnitMajor=drachma
UnitMinor=lepta
Ratio=100
Name=Greek Drachma
[HKD]
ISOName=HKD
ISOCode=344
UnitMajor=dollar
UnitMinor=cent
Ratio=100
Name=Hong Kong Dollar
[ISK]
ISOName=ISK
ISOCode=352
UnitMajor=kr�na
UnitMinor=aurar
Ratio=100
Name=Icelandic Kr�na
[INR]
ISOName=INR
ISOCode=356
UnitMajor=rupee
UnitMinor=paise
Ratio=100
Name=Indian Rupee
[ILS]
ISOName=ILS
ISOCode=376
UnitMajor=new shekel
UnitMinor=agorot
Ratio=100
Name=Israel Shekel
[ITL]
ISOName=ITL
ISOCode=380
UnitMajor=lira
UnitMinor=ml
Ratio=100
Name=Italian Lira
[JPY]
ISOName=JPY
ISOCode=392
UnitMajor=yen
UnitMinor=sen
Ratio=100
Name=Japanese Yen
[MXN]
ISOName=MXN
ISOCode=484
UnitMajor=peso
UnitMinor=centavo
Ratio=100
Name=Mexican Peso
[NZD]
ISOName=NZD
ISOCode=554
UnitMajor=dollar
UnitMinor=cent
Ratio=100
Name=New Zealand Dollar
[NOK]
ISOName=NOK
ISOCode=578
UnitMajor=krone
UnitMinor=�re
Ratio=100
Name=Norwegian Krone
[PLZ]
ISOName=PLZ
ISOCode=616
UnitMajor=zloty
UnitMinor=groszy
Ratio=100
Name=Poland New Zloty
[PTE]
ISOName=PTE
ISOCode=620
UnitMajor=escudo
UnitMinor=centavo
Ratio=100
Name=Portuguese Escudo
[RUR]
ISOName=RUR
ISOCode=810
UnitMajor=ruble
UnitMinor=kopeck
Ratio=100
Name=Russian Federation Rouble
[SGD]
ISOName=SGD
ISOCode=702
UnitMajor=dollar
UnitMinor=cent
Ratio=100
Name=Singapore Dollar
[ESP]
ISOName=ESP
ISOCode=724
UnitMajor=peseta
UnitMinor=centimo
Ratio=100
Name=Spanish Peseta
[GBP]
ISOName=GBP
ISOCode=826
UnitMajor=pound
UnitMinor=pence
Ratio=100
Name=Sterling
[SEK]
ISOName=SEK
ISOCode=752
UnitMajor=krona (pl. kronor)
UnitMinor=�re
Ratio=100
Name=Swedish Krona
[CHF]
ISOName=CHF
ISOCode=756
UnitMajor=franc
UnitMinor=rappen
Ratio=100
Name=Swiss Franc
[USD]
ISOName=USD
ISOCode=840
UnitMajor=dollar
UnitMinor=cent
Ratio=100
Name=US DOLLAR
[DTR]
ISOName=DTR
ISOCode=005
UnitMajor=rex
UnitMinor=campi
Ratio=100
Name=Dinotopia Rex
[ZQP]
ISOName=ZQP
ISOCode=002
UnitMajor=pazoor
UnitMinor=dharma
Ratio=100
Name=Zothique Pazoor
[LAM]
ISOName=LAM
ISOCode=001
UnitMajor=minim
UnitMinor=speck
Ratio=100
Name=Lilliputia Minim
[BNG]
ISOName=BNG
ISOCode=008
UnitMajor=gargantua
UnitMinor=bloat
Ratio=100
Name=Brobdinagian Gargantua
[ELE]
ISOName=ELE
ISOCode=011
UnitMajor=elbo
UnitMinor=kni
Ratio=100
Name=Elbonia Elbo
[SBD]
ISOName=SBD
ISOCode=333
UnitMajor=dunge
UnitMinor=slop
Ratio=100
Name=Slobovia Dunge
[RYE]
ISOName=RYE
ISOCode=666
UnitMajor=eldritch
UnitMinor=voor
Ratio=100
Name=Rlyeh Eldritch

9842
components/systools/source/run/stccycnv.dat Normal file
View File

File diff suppressed because it is too large Load Diff

848
components/systools/source/run/stconst.pas Normal file
View File

@ -0,0 +1,848 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StConst.pas 4.04 *}
{*********************************************************}
{* SysTools: Base unit for SysTools *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
unit StConst;
{-Resource constants for SysTools}
interface
uses
SysUtils;
const
StVersionStr = '4.04';
const
{string table constants for STREGINI}
stscFalseString = 0;
stscTrueString = 1;
stscNoFileKey = 2;
stscInvalidPKey = 3;
stscNoWin32S = 4;
stscCreateKeyFail = 5;
stscOpenKeyFail = 6;
stscIniWriteFail = 7;
stscRegWriteFail = 8;
stscNoKeyName = 9;
stscQueryKeyFail = 10;
stscEnumKeyFail = 11;
stscEnumValueFail = 12;
stscIniDeleteFail = 13;
stscKeyHasSubKeys = 14;
stscDeleteKeyFail = 15;
stscIniDelValueFail = 16;
stscRegDelValueFail = 17;
stscOutputFileExists = 18;
stscFileHasExtension = 19;
stscSaveKeyFail = 20;
stscNo16bitSupport = 21;
stscCantFindInputFile = 22;
stscLoadKeyFail = 23;
stscUnloadKeyFail = 24;
stscNotWinNTPlatform = 25;
stscBadOptionsKeyCombo = 26;
stscRestoreKeyFail = 27;
stscReplaceKeyFail = 28;
stscNoIniFileSupport = 29;
stscRemoteKeyIsOpen = 30;
stscConnectRemoteKeyFail = 31;
stscCloseRemoteKeyFail = 32;
stscFlushKeyFail = 33;
stscBufferDataSizesDif = 34;
stscKeyIsEmptyNotExists = 35;
stscGetSecurityFail = 36;
stscSetSecurityFail = 37;
stscByteArrayTooLarge = 38;
stscQueryValueFail = 39;
stscNoValueNameSpecified = 40;
{string table constants for container classes}
stscNoCompare = 51; {Compare property must be set}
stscBadType = 52; {an incompatible class is passed to a method}
stscBadSize = 53; {bad size for TStDictionary, TStBits, TStCollection}
stscDupNode = 54; {attempt to add duplicate node to TStTree}
stscBadIndex = 55; {bad index passed to TStBits or large array}
stscBadWinMode = 56; {requires enhanced mode operation}
stscUnknownClass = 57; {container class name not registered}
stscUnknownNodeClass = 58; {container node class name not registered}
stscNoStoreData = 59; {container has no store data routine}
stscNoLoadData = 60; {container has no load data routine}
stscWrongClass = 61; {container class and streamed class not equal}
stscWrongNodeClass = 62; {container node class and streamed class not equal}
stscBadCompare = 63; {invalid compare function or unable to assign now}
stscTooManyCols = 64; {assign a matrix with >1 col to array}
stscBadColCount = 65; {assign a matrix with wrong col count to virtual matrix}
stscBadElSize = 66; {assign a matrix with wrong elem size to virtual matrix}
stscBadDups = 67; {setting Dups to False in a non-empty sorted collection}
{string table constants for sorting unit}
stscTooManyFiles = 71; {too many merge files in TStSorter}
stscFileCreate = 72; {error creating file in TStSorter}
stscFileOpen = 73; {error opening file in TStSorter}
stscFileWrite = 74; {error writing file in TStSorter}
stscFileRead = 75; {error reading file in TStSorter}
stscBadState = 76; {TStSorter in wrong state}
{string table constants for Bcd unit}
stscBcdBadFormat = 81; {bad BCD format}
stscBcdOverflow = 82; {BCD larger than 10**64}
stscBcdDivByZero = 83; {BCD divide by zero}
stscBcdBadInput = 84; {BCD negative input to sqrt, ln, or power}
stscBcdBufOverflow = 85; {buffer overflow in FormatBcd}
stscNoVerInfo = 100; {no version info in file}
stscVerInfoFail = 101; {error reading version info}
(*
{shell string constants}
stscShellVersionError = 110; {not available in this version of Shell32.dll}
stscShellFileOpSrcError = 111; {no source files specified}
stscShellFileOpDstError = 112; {no destination files specified}
stscShellFileOpMapError = 113; {mapping incomplete}
stscShellFormatError = 114; {format error}
stscShellFormatCancel = 115; {format cancelled}
stscShellFormatNoFormat = 116; {drive cannot be formatted}
stscShellFormatBadDrive = 117; {not removable drive}
stscTrayIconInvalidOS = 118; {bad OS (NT 3.51)}
stscTrayIconCantAdd = 119; {can't add icon to the tray}
stscTrayIconCantDelete = 120; {can't delete icon from the tray}
stscTrayIconError = 121; {general tray icon error}
stscBadDropTarget = 122; {drop target is not TWinControl}
stscCOMInitFailed = 123; {COInitialize failed}
stscNoPathSpecified = 124; {No destination path for shortcut}
stscIShellLinkError = 125; {Error creating IShellLink}
stscNotShortcut = 126; {File is not a shortcut}
stscTrayIconClose = 127; {Close}
stscTrayIconRestore = 128; {Restore}
stscInvalidTargetFile = 130; {Shortcut target file not found}
stscShellFileOpDelete = 131; {Can't use file mappings with delete op}
stscShellFileNotFound = 132; {One or more source files is missing}
stscTrayIconDuplicate = 133; {Cant' have more than one tray icon}
stscBadVerInfoKey = 134; {User-defined key not found in ver info}
stscImageListInvalid = 135; {No image list assigned.}
*)
stscBadVerInfoKey = 134; {User-defined key not found in ver info}
{barcode errors}
stscInvalidUPCACodeLen = 140;
stscInvalidCharacter = 141;
stscInvalidCheckCharacter = 142;
stscInvalidUPCECodeLen = 143;
stscInvalidEAN8CodeLen = 144;
stscInvalidEAN13CodeLen = 145;
stscInvalidSupCodeLen = 146;
{stexpr errors}
stscExprEmpty = 150; {empty expression}
stscExprBadNum = 151; {error in floating point number}
stscExprBadChar = 152; {unknown character}
stscExprOpndExp = 153; {expected function, number, sign, or (}
stscExprNumeric = 154; {numeric error}
stscExprBadExp = 155; {invalid expression}
stscExprOpndOvfl = 156; {operand stack overflow}
stscExprUnkFunc = 157; {unknown function identifier}
stscExprLParExp = 158; {left parenthesis expected}
stscExprRParExp = 159; {right parenthesis expected}
stscExprCommExp = 160; {list separator (comma) expected}
stscExprDupIdent = 161; {duplicate identifier}
{ststat errors}
stscStatBadCount = 170; {unequal or bad counts of array elements}
stscStatBadParam = 171; {invalid parameter}
stscStatBadData = 172; {invalid data point in array}
stscStatNoConverge = 173; {no convergence in numerical routine}
{stfin errors}
stscFinBadArg = 180;
stscFinNoConverge = 181;
{stmime errors}
stscBadEncodeFmt = 190;
stscBadAttachment = 191;
stscDupeString = 192;
stscInStream = 193;
{ststring errors}
stscOutOfBounds = 200; {Index out of string bounds}
{stBarPN errors}
stscInvalidLength = 210;
{StHTML errors}
stscNoInputFile = 215;
stscNoOutputFile = 216;
stscInFileError = 217;
stscOutFileError = 218;
stscWordDelimiters = 219;
stscInvalidSLEntry = 220;
stscBadStream = 221;
{StShlCtl constansts}
stscName = 230;
stscSize = 231;
stscType = 232;
stscModified = 233;
stscAttributes = 234;
stscFileFolder = 235;
stscSystemFolder = 236;
stscOriginalLoc = 237;
stscDateDeleted = 238;
stscFile = 239;
stscInvalidFolder = 240;
stscFolderReadOnly = 241;
{StSpawnApplication errors}
stscInsufficientData= 250;
{StMemoryMappedFile errors}
stscCreateFileFailed = 260;
stscFileMappingFailed= 261;
stscCreateViewFailed = 262;
stscBadOrigin = 263;
stscGetSizeFailed = 264;
{buffered stream errors}
stscNilStream = 270;
stscNoSeekForRead = 271;
stscNoSeekForWrite = 272;
stscCannotWrite = 273;
stscBadTerminator = 274;
stscBadLineLength = 275;
stscCannotSetSize = 276;
{RegEx errors}
stscUnknownError = 290;
stscExpandingClass = 291;
stscAlternationFollowsClosure = 292;
stscUnbalancedParens = 293;
stscFollowingClosure = 294;
stscPatternError = 295;
stscUnbalancedTag = 296;
stscNoPatterns = 297;
stscPatternTooLarge = 298;
stscStreamsNil = 299;
stscInTextStreamError = 300;
stscOutTextStreamError = 301;
stscClosureMaybeEmpty = 302;
stscInFileNotFound = 303;
stscREInFileError = 304;
stscOutFileDelete = 305;
stscOutFileCreate = 306;
{StNet errors 320-339}
stscNetNoManualCreate = 320;
stscNetUnknownError = 321;
stscNetGroupNotSpecified = 322;
stscNetDateSpecifiedOutOfRange = 323;
stscNetInvalidParameter = 324;
stscNetInvalidItemType = 325;
{StNetConnection errors 330-334}
{StNetPerformance errors 335-339}
{StNetMessage errors 340-344}
{StMoney errors 400-429}
// stscMoneyIdxOutOfRange = 400; //'Index out of range (%s)'
stscMoneyNilResult = 401; //'Nil result parameter'
stscMoneyNilParameter = 402; //'Nil parameter to operation'
stscMoneyCurrenciesNotMatch = 403; //'Currencies do not match'
stscMoneyNoExchangeRatesAvail = 410; //'No Exchange Rates Available'
stscMoneyInvalidExchangeParams = 411; //'Invalid exchange parameters'
stscMoneyInvalidTriangleExchange = 412; //'Invalid triangle exchange'
stscMoneyNoSuchExchange = 413; //'No exchange rate for %s->%s available'
stscMoneyMissingIntermediateRate = 414; //''Intermediate exchange rate for %s->%s missing'
stscMoneyInvalidExchRate = 415; //'Exchange rate is missing a property value'
stscMoneyTriExchUsesTriExch = 415; //'Triangular exchange rate is using triangular exchange rates'
stscDecMathRoundPlaces = 423; //'Decimal math: the number of decimal places to round to must be betwen 0 and 16'
stscDecMathAsIntOverflow = 424; //'Decimal math: current value overflows an integer'
stscDecMathConversion = 425; //'Decimal math: string value not a valid number';
stscDecMathDivByZero = 426; //'Decimal math: division by zero attempted'
stscDecMathNegExp = 427; //'Decimal math: cannot raise to a negative power';
stscDecMathMultOverflow = 428; //'Decimal math: result overflowed during multiplication'
stscDecMathDivOverflow = 429; //'Decimal math: result overflowed during division'
{ Text Data Set, Merge, and Export errors }
stscTxtDatNoSuchField = 430; //'No such field'
stscTxtDatUniqueNameRequired = 431; //'Field name must be unique'
stscTxtDatUnhandledVariant = 432; //'Unhandled Variant Type'
stscTxtDatInvalidSchema = 433; //'Invalid Schema'
stscTxtDatRecordSetOpen = 434; //'Cannot perform this operation on an open record set'
{PRNG errors 460-479}
stscPRNGDegFreedom = 460; //'StRandom: the number of degrees of freedom should be greater than zero'
stscPRNGBetaShape = 461; //'StRandom: the Beta distribution shape values should be greater than zero'
stscPRNGMean = 462; //'StRandom: the mean must be greater than zero'
stscPRNGGammaShape = 463; //'StRandom: the Gamma distribution shape must be greater than zero'
stscPRNGGammaScale = 464; //'StRandom: the Gamma distribution scale must be greater than zero'
stscPRNGStdDev = 465; //'StRandom: the standard deviation must be greater than zero'
stscPRNGWeibullShape = 466; //'StRandom: the Weibull distribution shape must be greater than zero'
stscPRNGWeibullScale = 467; //'StRandom: the Weibull distribution scale must be greater than zero'
stscPRNGLimit = 468; //'StRandom: the limit must be greater than zero'
stscPRNGUpperLimit = 469; //'StRandom: the upper limit must be greater than the lower limit'
stscPRNGErlangOrder = 470; //'StRandom: the Erlang distribution's order must be greater than zero'
resourcestring
stscSysStringListFull = 'String list is full';
stscSysBadStartDir = 'Invalid starting directory';
stscFalseStringS = 'FALSE';
stscTrueStringS = 'TRUE';
stscNoFileKeyS = 'No Ini File or Primary Key specified';
stscInvalidPKeyS = 'Invalid primary key specified';
stscNoWin32SS = 'RegIni Class not supported under Win32s';
stscCreateKeyFailS = 'Failed to create key\nError Code: %d';
stscOpenKeyFailS = 'Failed to open key\nError Code: %d';
stscIniWriteFailS = 'Failed to write value to INI file';
stscRegWriteFailS = 'Failed to write value to Registry\nError Code: %d';
stscNoKeyNameS = 'No key name specified';
stscQueryKeyFailS = 'Unable to query specified key\nError Code: %d';
stscEnumKeyFailS = 'Unable to enumerate key\nError Code: %d';
stscEnumValueFailS = 'Unable to enumerate value\nError Code: %d';
stscIniDeleteFailS = 'Unable to delete section from INI file';
stscKeyHasSubKeysS = 'Can not delete key which has subkeys (%d)';
stscDeleteKeyFailS = 'Unable to delete key\nError Code: %d';
stscIniDelValueFailS = 'Unable to delete value from INI file';
stscRegDelValueFailS = 'Unable to delete value from key\nError Code: %d';
stscOutputFileExistsS = 'Output file exists';
stscFileHasExtensionS = 'File name can not have an extension';
stscSaveKeyFailS = 'Unable to save key\nError Code: %d';
stscNo16bitSupportS = 'Function not supported in 16-bit applications';
stscCantFindInputFileS = 'Can not find input file';
stscLoadKeyFailS = 'Unable to load key\nError Code: %d';
stscUnloadKeyFailS = 'Unable to unload key\nErrorCode: %d';
stscNotWinNTPlatformS = 'Function not supported on this platform';
stscBadOptionsKeyComboS = 'Selection options incompatible\nwith specified primary key';
stscRestoreKeyFailS = 'Unable to restore key\nError Code: %d';
stscReplaceKeyFailS = 'Unable to replace key\nError Code: %d';
stscNoIniFileSupportS = 'Function not supported on INI files';
stscRemoteKeyIsOpenS = 'Remote key already open';
stscConnectRemoteKeyFailS = 'Unable to connect to remote registry key\nError Code: %d';
stscCloseRemoteKeyFailS = 'Unable to close remote registry key';
stscFlushKeyFailS = 'Unable to flush specified key';
stscBufferDataSizesDifS = 'Buffer size differs from data size\nBuffer: %d Data: %d';
stscKeyIsEmptyNotExistsS = 'Specified Key is empty or does not exist';
stscGetSecurityFailS = 'Failed to Get Security Information\nError Code: %d';
stscSetSecurityFailS = 'Failed to Set Security Information\nError Code: %d';
stscByteArrayTooLargeS = 'Size of byte array exceeds limit';
stscQueryValueFailS = 'Unable to query value in key';
stscNoValueNameSpecifiedS = 'No Value Name specified';
stscNoCompareS = 'Compare property must be set';
stscBadTypeS = 'An incompatible class is passed to a method';
stscBadSizeS = 'Bad size parameter';
stscDupNodeS = 'Attempt to add duplicate node to TStTree';
stscBadIndexS = 'Index is out of range';
stscBadWinModeS = 'Requires enhanced mode operation for Windows 3.1x';
stscUnknownClassS = 'Container class name %s read from stream is unregistered';
stscUnknownNodeClassS = 'Node class name %s read from stream is unregistered';
stscNoStoreDataS = 'Container''s StoreData property is unassigned';
stscNoLoadDataS = 'Container''s LoadData property is unassigned';
stscWrongClassS = 'Class name on stream differs from object''s class';
stscWrongNodeClassS = 'Node class name on stream differs from object''s node class';
stscBadCompareS = 'Unable to assign this compare function now';
stscTooManyColsS = 'Cannot assign a matrix with more than 1 column to an array';
stscBadColCountS = 'Can only assign a matrix to a virtual matrix if column counts are equal';
stscBadElSizeS = 'Can only assign a matrix to a virtual matrix if element sizes are equal';
stscBadDupsS = 'Can only set Duplicates to False in an empty sorted collection';
stscTooManyFilesS = 'Too many merge files in TStSorter';
stscFileCreateS = 'Error creating file';
stscFileOpenS = 'Error opening file';
stscFileWriteS = 'Error writing file (bytes written <> bytes requested)';
stscFileReadS = 'Error reading file (bytes read <> bytes requested)';
stscBadStateS = 'TStSorter in wrong state';
stscBcdBadFormatS = 'Bad BCD format';
stscBcdOverflowS = 'BCD larger than 10**64';
stscBcdDivByZeroS = 'BCD divide by zero';
stscBcdBadInputS = 'BCD negative input to sqrt, ln, or power';
stscBcdBufOverflowS = 'Buffer overflow in FormatBcd';
stscNoVerInfoS = 'File does not contain version info';
stscVerInfoFailS = 'Unable to read version info';
(*
stscShellVersionErrorS = 'Operation not supported in this version of the shell';
stscShellFileOpSrcErrorS = 'No source files specified';
stscShellFileOpDstErrorS = 'No destination files specified';
stscShellFileOpMapErrorS = 'File mapping incomplete';
stscShellFormatErrorS = 'Format failed';
stscShellFormatCancelS = 'Format cancelled';
stscShellFormatNoFormatS = 'Drive cannot be formatted';
stscShellFormatBadDriveS = 'Invalid drive. Drive is not removable';
stscTrayIconInvalidOSS = 'Operating system does not support tray icons';
stscTrayIconCantAddS = 'Error adding tray icon';
stscTrayIconCantDeleteS = 'Error removing tray icon';
stscTrayIconErrorS = 'Tray icon error';
stscBadDropTargetS = 'Drop target must be a TWinControl descendant';
stscCOMInitFailedS = 'Cannot initialize COM';
stscNoPathSpecifiedS = 'Destination directory not specified';
stscIShellLinkErrorS = 'Error creating IShellLink';
stscNotShortcutS = 'File is not a shortcut';
stscTrayIconCloseS = '&Close';
stscTrayIconRestoreS = '&Restore';
stscInvalidTargetFileS = 'Cannot create shortcut. Target file does not exist';
stscShellFileOpDeleteS = 'Cannot use file mappings in a delete operation';
stscShellFileNotFoundS = 'Source file error, file not found';
stscTrayIconDuplicateS = 'Cannot have more than one StTrayIcon per application';
stscBadVerInfoKeyS = 'The specified key cannnot be found in version info';
stscImageListInvalidS = 'ImageList is not assigned';
*)
stscBadVerInfoKeyS = 'The specified key cannnot be found in version info';
stscInvalidUPCACodeLenS = 'Invalid code length (must be 11 or 12)';
stscInvalidCharacterS = 'Invalid character';
stscInvalidCheckCharacterS = 'Invalid check character';
stscInvalidUPCECodeLenS = 'Invalid code length (must be 6)';
stscInvalidEAN8CodeLenS = 'Invalid code length (must be 7 or 8)';
stscInvalidEAN13CodeLenS = 'Invalid code length (must be 12 or 13)';
stscInvalidSupCodeLenS = 'Invalid supplemental code length (must be 2 or 5)';
stscFinBadArgS = 'Invalid argument to financial function';
stscFinNoConvergeS = 'Function does not converge';
stscExprEmptyS = 'Empty expression';
stscExprBadNumS = 'Error in floating point number';
stscExprBadCharS = 'Unknown character';
stscExprOpndExpS = 'Expected function, number, sign, or (';
stscExprNumericS = 'Numeric error';
stscExprBadExpS = 'Invalid expression';
stscExprOpndOvflS = 'Operand stack overflow';
stscExprUnkFuncS = 'Unknown function identifier';
stscExprLParExpS = 'Left parenthesis expected';
stscExprRParExpS = 'Right parenthesis expected';
stscExprCommExpS = 'List separator expected';
stscExprDupIdentS = 'Duplicate identifier';
stscBadEncodeFmtS = 'Encoding Format Not Supported';
stscBadAttachmentS = 'Attachment Doesn''t Exist';
stscDupeStringS = 'Duplicate string';
stscInStreamS = 'Error in input stream';
stscOutOfBoundsS = 'Index out of string bounds';
stscInvalidLengthS = 'POSTNET code must be 5, 9 or 11 digits';
stscNoInputFileS = 'Input file not specified';
stscNoOutputFileS = 'Output file not specified';
stscInFileErrorS = 'Error opening input file';
stscOutFileErrorS = 'Error creating output file';
stscNameS = 'Name';
stscSizeS = 'Size';
stscTypeS = 'Type';
stscModifiedS = 'Modified';
stscAttributesS = 'Attributes';
stscFileFolderS = 'File Folder';
stscSystemFolderS = 'System Folder';
stscOriginalLocS = 'Original Location';
stscDateDeletedS = 'Date Deleted';
stscFileS = 'File';
stscInvalidFolderS = 'Invalid folder';
stscFolderReadOnlyS = 'Cannot create folder: Parent folder is read-only';
stscInvalidSortDirS = 'Invalid sort direction';
stscInsufficientDataS = 'FileName cannot be empty when RunParameters is specified';
stscCreateFileFailedS = 'CreateFile failed';
stscFileMappingFailedS = 'CreateFileMapping failed';
stscCreateViewFailedS = 'MapViewOfFile failed';
stscBadOriginS = 'Bad origin parameter for call to Seek';
stscGetSizeFailedS = 'Error reading size of existing file';
stscNilStreamS = 'Buffered/text stream: Attempted to read, write, or seek and underlying stream is nil';
stscNoSeekForReadS = 'Buffered/text stream: Could not seek to the correct position in the underlying stream (for read request)';
stscNoSeekForWriteS = 'Buffered/text stream: Could not seek to the correct position in the underlying stream (for write request)';
stscCannotWriteS = 'Buffered/text stream: Could not write the entire buffer to the underlying stream';
stscBadTerminatorS = 'Text stream: Case statement was used with a bad value of LineTerminator';
stscBadLineLengthS = 'Text stream: Length of a fixed line must be between 1 and 4096 bytes';
stscCannotSetSizeS = 'Buffered/text stream: Cannot set the size of the underlying stream (needs OnSetStreamSize event)';
stscUnknownErrorS = 'Unknown error creating a pattern token';
stscExpandingClassS = 'Problem in expanding character class';
stscAlternationFollowsClosureS = 'Alternation cannot immediately follow a closure marker';
stscUnbalancedParensS = 'Unbalanced nesting parentheses';
stscFollowingClosureS = 'Closure cannot immediately follow BegOfLine, EndOfLine or another closure';
stscPatternErrorS = 'Error detected near end of pattern';
stscUnbalancedTagS = 'Unbalanced tag marker';
stscNoPatternsS = 'No Match, Replace, or SelAvoid Patterns defined';
stscPatternTooLargeS = 'Pattern exceeds MaxPatLen';
stscStreamsNilS = 'Input and/or output stream is not assigned';
stscInTextStreamErrorS = 'Error creating internal input text stream';
stscOutTextStreamErrorS = 'Error creating internal output text stream';
stscClosureMaybeEmptyS = 'A * or + operand could be empty';
stscOutFileDeleteS = 'Error deleting old previous file';
stscInFileNotFoundS = 'Input file not found';
stscREInFileErrorS = 'Error creating internal text stream';
stscOutFileCreateS = 'Error creating output file';
stscNetNoManualCreateS = 'Can''t manually create an object of this type';
stscNetUnknownErrorS = 'Unknown network error';
stscNetGroupNotSpecifiedS = 'Local or global group not specified';
stscNetDateSpecifiedOutOfRangeS = 'Date specified out or range';
stscNetInvalidParameterS = 'Invalid parameter';
stscNetInvalidItemTypeS = 'Invalid item type for this method';
stscStatBadCountS = 'Unequal or bad counts of array elements';
stscStatBadParamS = 'Invalid parameter';
stscStatBadDataS = 'Invalid data point in array';
stscStatNoConvergeS = 'no convergence in numerical routine';
stscWordDelimitersS = '219';
stscInvalidSLEntryS = '220';
stscBadStreamS = '221';
stscMoneyIdxOutOfRangeS = 'Index out of range (%s)';
stscMoneyNilResultS = 'Nil result parameter';
stscMoneyNilParameterS = 'Nil parameter to operation';
stscMoneyCurrenciesNotMatchS = 'Currencies do not match';
stscMoneyNoExchangeRatesAvailS = 'No Exchange Rates Available';
stscMoneyInvalidExchangeParamsS = 'Invalid exchange parameters';
stscMoneyInvalidTriangleExchangeS = 'Invalid triangle exchange';
stscMoneyNoSuchExchangeS = 'No exchange rate for %s->%s available';
stscMoneyMissingIntermediateRateS = 'Intermediate exchange rate for %s->%s missing';
stscMoneyInvalidExchRateS = 'Exchange rate is missing a property value';
stscMoneyTriExchUsesTriExchS = 'Triangular exchange rate is using triangular exchange rates';
stscDecMathRoundPlacesS = 'Decimal math: the number of decimal places to round to must be betwen 0 and 16';
stscDecMathAsIntOverflowS = 'Decimal math: current value overflows an integer';
stscDecMathConversionS = 'Decimal math: string value not a valid number';
stscDecMathDivByZeroS = 'Decimal math: division by zero attempted';
stscDecMathNegExpS = 'Decimal math: cannot raise to a negative power';
stscDecMathMultOverflowS = 'Decimal math: result overflowed during multiplication';
stscDecMathDivOverflowS = 'Decimal math: result overflowed during division';
stscTxtDatNoSuchFieldS = 'No such field';
stscTxtDatUniqueNameRequiredS = 'Field name must be unique';
stscTxtDatUnhandledVariantS = 'Unhandled Variant Type';
stscTxtDatInvalidSchemaS = 'Invalid Schema';
stscTxtDatRecordSetOpenS = 'Cannot perform this operation on an open record set';
stscPRNGDegFreedomS = 'StRandom: the number of degrees of freedom should be greater than zero';
stscPRNGBetaShapeS = 'StRandom: the Beta distribution shape values should be greater than zero';
stscPRNGMeanS = 'StRandom: the mean must be greater than zero';
stscPRNGGammaShapeS = 'StRandom: the Gamma distribution shape must be greater than zero';
stscPRNGGammaScaleS = 'StRandom: the Gamma distribution scale must be greater than zero';
stscPRNGStdDevS = 'StRandom: the standard deviation must be greater than zero';
stscPRNGWeibullShapeS = 'StRandom: the Weibull distribution shape must be greater than zero';
stscPRNGWeibullScaleS = 'StRandom: the Weibull distribution scale must be greater than zero';
stscPRNGLimitS = 'StRandom: the limit must be greater than zero';
stscPRNGUpperLimitS = 'StRandom: the upper limit must be greater than the lower limit';
stscPRNGErlangOrderS = 'StRandom: the Erlang distribution''s order must be greater than zero';
type
StStrRec = record
ID: Integer;
Str: string;
end;
const
SysToolsStrArray : array [0..174] of StStrRec = (
{string table constants for STREGINI}
(ID: stscFalseString; Str: stscFalseStringS),
(ID: stscTrueString; Str: stscTrueStringS),
(ID: stscNoFileKey; Str: stscNoFileKeyS),
(ID: stscInvalidPKey; Str: stscInvalidPKeyS),
(ID: stscNoWin32S; Str: stscNoWin32SS),
(ID: stscCreateKeyFail; Str: stscCreateKeyFailS),
(ID: stscOpenKeyFail; Str: stscOpenKeyFailS),
(ID: stscIniWriteFail; Str: stscIniWriteFailS),
(ID: stscRegWriteFail; Str: stscRegWriteFailS),
(ID: stscNoKeyName; Str: stscNoKeyNameS),
(ID: stscQueryKeyFail; Str: stscQueryKeyFailS),
(ID: stscEnumKeyFail; Str: stscEnumKeyFailS),
(ID: stscEnumValueFail; Str: stscEnumValueFailS),
(ID: stscIniDeleteFail; Str: stscIniDeleteFailS),
(ID: stscKeyHasSubKeys; Str: stscKeyHasSubKeysS),
(ID: stscDeleteKeyFail; Str: stscDeleteKeyFailS),
(ID: stscIniDelValueFail; Str: stscIniDelValueFailS),
(ID: stscRegDelValueFail; Str: stscRegDelValueFailS),
(ID: stscOutputFileExists; Str: stscOutputFileExistsS),
(ID: stscFileHasExtension; Str: stscFileHasExtensionS),
(ID: stscSaveKeyFail; Str: stscSaveKeyFailS),
(ID: stscNo16bitSupport; Str: stscNo16bitSupportS),
(ID: stscCantFindInputFile; Str: stscCantFindInputFileS),
(ID: stscLoadKeyFail; Str: stscLoadKeyFailS),
(ID: stscUnloadKeyFail; Str: stscUnloadKeyFailS),
(ID: stscNotWinNTPlatform; Str: stscNotWinNTPlatformS),
(ID: stscBadOptionsKeyCombo; Str: stscBadOptionsKeyComboS),
(ID: stscRestoreKeyFail; Str: stscRestoreKeyFailS),
(ID: stscReplaceKeyFail; Str: stscReplaceKeyFailS),
(ID: stscNoIniFileSupport; Str: stscNoIniFileSupportS),
(ID: stscRemoteKeyIsOpen; Str: stscRemoteKeyIsOpenS),
(ID: stscConnectRemoteKeyFail; Str: stscConnectRemoteKeyFailS),
(ID: stscCloseRemoteKeyFail; Str: stscCloseRemoteKeyFailS),
(ID: stscFlushKeyFail; Str: stscFlushKeyFailS),
(ID: stscBufferDataSizesDif; Str: stscBufferDataSizesDifS),
(ID: stscKeyIsEmptyNotExists; Str: stscKeyIsEmptyNotExistsS),
(ID: stscGetSecurityFail; Str: stscGetSecurityFailS),
(ID: stscSetSecurityFail; Str: stscSetSecurityFailS),
(ID: stscByteArrayTooLarge; Str: stscByteArrayTooLargeS),
(ID: stscQueryValueFail; Str: stscQueryValueFailS),
(ID: stscNoValueNameSpecified; Str: stscNoValueNameSpecifiedS),
{string table constants for container classes}
(ID: stscNoCompare; Str: stscNoCompareS), {Compare property must be set}
(ID: stscBadType; Str: stscBadTypeS), {an incompatible class is passed to a method}
(ID: stscBadSize; Str: stscBadSizeS), {bad size for TStDictionary, TStBits, TStCollection}
(ID: stscDupNode; Str: stscDupNodeS), {attempt to add duplicate node to TStTree}
(ID: stscBadIndex; Str: stscBadIndexS), {bad index passed to TStBits or large array}
(ID: stscBadWinMode; Str: stscBadWinModeS), {requires enhanced mode operation}
(ID: stscUnknownClass; Str: stscUnknownClassS), {container class name not registered}
(ID: stscUnknownNodeClass; Str: stscUnknownNodeClassS), {container node class name not registered}
(ID: stscNoStoreData; Str: stscNoStoreDataS), {container has no store data routine}
(ID: stscNoLoadData; Str: stscNoLoadDataS), {container has no load data routine}
(ID: stscWrongClass; Str: stscWrongClassS), {container class and streamed class not equal}
(ID: stscWrongNodeClass; Str: stscWrongNodeClassS), {container node class and streamed class not equal}
(ID: stscBadCompare; Str: stscBadCompareS), {invalid compare function or unable to assign now}
(ID: stscTooManyCols; Str: stscTooManyColsS), {assign a matrix with >1 col to array}
(ID: stscBadColCount; Str: stscBadColCountS), {assign a matrix with wrong col count to virtual matrix}
(ID: stscBadElSize; Str: stscBadElSizeS), {assign a matrix with wrong elem size to virtual matrix}
(ID: stscBadDups; Str: stscBadDupsS), {setting Dups to False in a non-empty sorted collection}
{string table constants for sorting unit}
(ID: stscTooManyFiles; Str: stscTooManyFilesS), {too many merge files in TStSorter}
(ID: stscFileCreate; Str: stscFileCreateS), {error creating file in TStSorter}
(ID: stscFileOpen; Str: stscFileOpenS), {error opening file in TStSorter}
(ID: stscFileWrite; Str: stscFileWriteS), {error writing file in TStSorter}
(ID: stscFileRead; Str: stscFileReadS), {error reading file in TStSorter}
(ID: stscBadState; Str: stscBadStateS), {TStSorter in wrong state}
{string table constants for Bcd unit}
(ID: stscBcdBadFormat; Str: stscBcdBadFormatS), {bad BCD format}
(ID: stscBcdOverflow; Str: stscBcdOverflowS), {BCD larger than 10**64}
(ID: stscBcdDivByZero; Str: stscBcdDivByZeroS), {BCD divide by zero}
(ID: stscBcdBadInput; Str: stscBcdBadInputS), {BCD negative input to sqrt, ln, or power}
(ID: stscBcdBufOverflow; Str: stscBcdBufOverflowS), {buffer overflow in FormatBcd}
(ID: stscNoVerInfo; Str: stscNoVerInfoS), {no version info in file}
(ID: stscVerInfoFail; Str: stscVerInfoFailS), {error reading version info}
(*
{shell string constants}
(ID: stscShellVersionError; Str: stscShellVersionErrorS), {not available in this version of Shell32.dll}
(ID: stscShellFileOpSrcError; Str: stscShellFileOpSrcErrorS), {no source files specified}
(ID: stscShellFileOpDstError; Str: stscShellFileOpDstErrorS), {no destination files specified}
(ID: stscShellFileOpMapError; Str: stscShellFileOpMapErrorS), {mapping incomplete}
(ID: stscShellFormatError; Str: stscShellFormatErrorS), {format error}
(ID: stscShellFormatCancel; Str: stscShellFormatCancelS), {format cancelled}
(ID: stscShellFormatNoFormat; Str: stscShellFormatNoFormatS), {drive cannot be formatted}
(ID: stscShellFormatBadDrive; Str: stscShellFormatBadDriveS), {not removable drive}
(ID: stscTrayIconInvalidOS; Str: stscTrayIconInvalidOSS), {bad OS (NT 3.51)}
(ID: stscTrayIconCantAdd; Str: stscTrayIconCantAddS), {can't add icon to the tray}
(ID: stscTrayIconCantDelete; Str: stscTrayIconCantDeleteS), {can't delete icon from the tray}
(ID: stscTrayIconError; Str: stscTrayIconErrorS), {general tray icon error}
(ID: stscBadDropTarget; Str: stscBadDropTargetS), {drop target is not TWinControl}
(ID: stscCOMInitFailed; Str: stscCOMInitFailedS), {COInitialize failed}
(ID: stscNoPathSpecified; Str: stscNoPathSpecifiedS), {No destination path for shortcut}
(ID: stscIShellLinkError; Str: stscIShellLinkErrorS), {Error creating IShellLink}
(ID: stscNotShortcut; Str: stscNotShortcutS), {File is not a shortcut}
(ID: stscTrayIconClose; Str: stscTrayIconCloseS), {Close}
(ID: stscTrayIconRestore; Str: stscTrayIconRestoreS), {Restore}
(ID: stscInvalidTargetFile; Str: stscInvalidTargetFileS), {Shortcut target file not found}
(ID: stscShellFileOpDelete; Str: stscShellFileOpDeleteS), {Can't use file mappings with delete op}
(ID: stscShellFileNotFound; Str: stscShellFileNotFoundS), {One or more source files is missing}
(ID: stscTrayIconDuplicate; Str: stscTrayIconDuplicateS), {Cant' have more than one tray icon}
(ID: stscBadVerInfoKey; Str: stscBadVerInfoKeyS), {User-defined key not found in ver info}
(ID: stscImageListInvalid; Str: stscImageListInvalidS), {No image list assigned.}
*)
(ID: stscBadVerInfoKey; Str: stscBadVerInfoKeyS), {User-defined key not found in ver info}
{barcode errors}
(ID: stscInvalidUPCACodeLen; Str: stscInvalidUPCACodeLenS),
(ID: stscInvalidCharacter; Str: stscInvalidCharacterS),
(ID: stscInvalidCheckCharacter; Str: stscInvalidCheckCharacterS),
(ID: stscInvalidUPCECodeLen; Str: stscInvalidUPCECodeLenS),
(ID: stscInvalidEAN8CodeLen; Str: stscInvalidEAN8CodeLenS),
(ID: stscInvalidEAN13CodeLen; Str: stscInvalidEAN13CodeLenS),
(ID: stscInvalidSupCodeLen; Str: stscInvalidSupCodeLenS),
{stexpr errors}
(ID: stscExprEmpty; Str: stscExprEmptyS), {empty expression}
(ID: stscExprBadNum; Str: stscExprBadNumS), {error in floating point number}
(ID: stscExprBadChar; Str: stscExprBadCharS), {unknown character}
(ID: stscExprOpndExp; Str: stscExprOpndExpS), {expected function, number, sign, or (}
(ID: stscExprNumeric; Str: stscExprNumericS), {numeric error}
(ID: stscExprBadExp; Str: stscExprBadExpS), {invalid expression}
(ID: stscExprOpndOvfl; Str: stscExprOpndOvflS), {operand stack overflow}
(ID: stscExprUnkFunc; Str: stscExprUnkFuncS), {unknown function identifier}
(ID: stscExprLParExp; Str: stscExprLParExpS), {left parenthesis expected}
(ID: stscExprRParExp; Str: stscExprRParExpS), {right parenthesis expected}
(ID: stscExprCommExp; Str: stscExprCommExpS), {list separator (comma) expected}
(ID: stscExprDupIdent; Str: stscExprDupIdentS), {duplicate identifier}
{ststat errors}
(ID: stscStatBadCount; Str: stscStatBadCountS), {unequal or bad counts of array elements}
(ID: stscStatBadParam; Str: stscStatBadParamS), {invalid parameter}
(ID: stscStatBadData; Str: stscStatBadDataS), {invalid data point in array}
(ID: stscStatNoConverge; Str: stscStatNoConvergeS), {no convergence in numerical routine}
{stfin errors}
(ID: stscFinBadArg; Str: stscFinBadArgS),
(ID: stscFinNoConverge; Str: stscFinNoConvergeS),
{stmime errors}
(ID: stscBadEncodeFmt; Str: stscBadEncodeFmtS),
(ID: stscBadAttachment; Str: stscBadAttachmentS),
(ID: stscDupeString; Str: stscDupeStringS),
(ID: stscInStream; Str: stscInStreamS),
{ststring errors}
(ID: stscOutOfBounds; Str: stscOutOfBoundsS), {Index out of string bounds}
{stBarPN errors}
(ID: stscInvalidLength; Str: stscInvalidLengthS),
{StHTML errors}
(ID: stscNoInputFile; Str: stscNoInputFileS),
(ID: stscNoOutputFile; Str: stscNoOutputFileS),
(ID: stscInFileError; Str: stscInFileErrorS),
(ID: stscOutFileError; Str: stscOutFileErrorS),
(ID: stscWordDelimiters; Str: stscWordDelimitersS),
(ID: stscInvalidSLEntry; Str: stscInvalidSLEntryS),
(ID: stscBadStream; Str: stscBadStreamS),
{StShlCtl constansts}
(ID: stscName; Str: stscNameS),
(ID: stscSize; Str: stscSizeS),
(ID: stscType; Str: stscTypeS),
(ID: stscModified; Str: stscModifiedS),
(ID: stscAttributes; Str: stscAttributesS),
(ID: stscFileFolder; Str: stscFileFolderS),
(ID: stscSystemFolder; Str: stscSystemFolderS),
(ID: stscOriginalLoc; Str: stscOriginalLocS),
(ID: stscDateDeleted; Str: stscDateDeletedS),
(ID: stscFile; Str: stscFileS),
(ID: stscInvalidFolder; Str: stscInvalidFolderS),
(ID: stscFolderReadOnly; Str: stscFolderReadOnlyS),
{StSpawnApplication errors}
(ID: stscInsufficientData; Str: stscInsufficientDataS),
{StMemoryMappedFile errors}
(ID: stscCreateFileFailed; Str: stscCreateFileFailedS),
(ID: stscFileMappingFailed; Str: stscFileMappingFailedS),
(ID: stscCreateViewFailed; Str: stscCreateViewFailedS),
(ID: stscBadOrigin; Str: stscBadOriginS),
(ID: stscGetSizeFailed; Str: stscGetSizeFailedS),
{buffered stream errors}
(ID: stscNilStream; Str: stscNilStreamS),
(ID: stscNoSeekForRead; Str: stscNoSeekForReadS),
(ID: stscNoSeekForWrite; Str: stscNoSeekForWriteS),
(ID: stscCannotWrite; Str: stscCannotWriteS),
(ID: stscBadTerminator; Str: stscBadTerminatorS),
(ID: stscBadLineLength; Str: stscBadLineLengthS),
(ID: stscCannotSetSize; Str: stscCannotSetSizeS),
{RegEx errors}
(ID: stscUnknownError; Str: stscUnknownErrorS),
(ID: stscExpandingClass; Str: stscExpandingClassS),
(ID: stscAlternationFollowsClosure; Str: stscAlternationFollowsClosureS),
(ID: stscUnbalancedParens; Str: stscUnbalancedParensS),
(ID: stscFollowingClosure; Str: stscFollowingClosureS),
(ID: stscPatternError; Str: stscPatternErrorS),
(ID: stscUnbalancedTag; Str: stscUnbalancedTagS),
(ID: stscNoPatterns; Str: stscNoPatternsS),
(ID: stscPatternTooLarge; Str: stscPatternTooLargeS),
(ID: stscStreamsNil; Str: stscStreamsNilS),
(ID: stscInTextStreamError; Str: stscInTextStreamErrorS),
(ID: stscOutTextStreamError; Str: stscOutTextStreamErrorS),
(ID: stscClosureMaybeEmpty; Str: stscClosureMaybeEmptyS),
(ID: stscInFileNotFound; Str: stscInFileNotFoundS),
(ID: stscREInFileError; Str: stscREInFileErrorS),
(ID: stscOutFileDelete; Str: stscOutFileDeleteS),
(ID: stscOutFileCreate; Str: stscOutFileCreateS),
{StNet errors 320-339}
(ID: stscNetNoManualCreate; Str: stscNetNoManualCreateS),
(ID: stscNetUnknownError; Str: stscNetUnknownErrorS),
(ID: stscNetGroupNotSpecified; Str: stscNetGroupNotSpecifiedS),
(ID: stscNetDateSpecifiedOutOfRange; Str: stscNetDateSpecifiedOutOfRangeS),
(ID: stscNetInvalidParameter; Str: stscNetInvalidParameterS),
(ID: stscNetInvalidItemType; Str: stscNetInvalidItemTypeS),
{ StMoney errors }
// (ID: stscMoneyIdxOutOfRange; Str: stscMoneyIdxOutOfRangeS),
(ID: stscMoneyNilResult; Str: stscMoneyNilResultS),
(ID: stscMoneyNilParameter; Str: stscMoneyNilParameterS),
(ID: stscMoneyCurrenciesNotMatch; Str: stscMoneyCurrenciesNotMatchS),
(ID: stscMoneyNoExchangeRatesAvail; Str: stscMoneyNoExchangeRatesAvailS),
(ID: stscMoneyInvalidExchangeParams; Str: stscMoneyInvalidExchangeParamsS),
(ID: stscMoneyInvalidTriangleExchange; Str: stscMoneyInvalidTriangleExchangeS),
(ID: stscMoneyNoSuchExchange; Str: stscMoneyNoSuchExchangeS),
(ID: stscMoneyMissingIntermediateRate; Str: stscMoneyMissingIntermediateRateS),
(ID: stscMoneyInvalidExchRate; Str: stscMoneyInvalidExchRateS),
(ID: stscMoneyTriExchUsesTriExch; Str: stscMoneyTriExchUsesTriExchS),
(ID: stscDecMathMultOverflow; Str: stscDecMathMultOverflowS),
(ID: stscDecMathDivOverflow; Str: stscDecMathDivOverflowS),
(ID: stscTxtDatNoSuchField; Str: stscTxtDatNoSuchFieldS),
(ID: stscTxtDatUniqueNameRequired; Str: stscTxtDatUniqueNameRequiredS),
(ID: stscTxtDatUnhandledVariant; Str: stscTxtDatUnhandledVariantS),
(ID: stscTxtDatInvalidSchema; Str: stscTxtDatInvalidSchemaS),
(ID: stscTxtDatRecordSetOpen; Str: stscTxtDatRecordSetOpenS)
);
function SysToolsStr(Index : Integer) : string;
implementation
function SysToolsStr(Index : Integer) : string;
var
i : Integer;
begin
for i := Low(SysToolsStrArray) to High(SysToolsStrArray) do
if SysToolsStrArray[i].ID = Index then
Result := SysToolsStrArray[i].Str;
end;
initialization
end.

382
components/systools/source/run/stcrc.pas Normal file
View File

@ -0,0 +1,382 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StCRC.pas 4.04 *}
{*********************************************************}
{* SysTools: Cyclic redundancy check unit for SysTools *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{
Note: CRC routines rely on overflows for their results,
so these need to be off:
}
{$R-}
{$Q-}
unit StCRC;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes,
StBase;
const
CrcBufSize = 2048;
CrcFileMode = fmOpenRead or fmShareDenyWrite;
function Adler32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
function Adler32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
function Adler32OfFile(FileName : String) : LongInt;
function Crc16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
function Crc16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
function Crc16OfFile(FileName : String) : Cardinal;
function Crc32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
function Crc32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
function Crc32OfFile(FileName : String) : LongInt;
function InternetSumPrim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
function InternetSumOfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
function InternetSumOfFile(FileName : String) : Cardinal;
function Kermit16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
function Kermit16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
function Kermit16OfFile(FileName : String) : Cardinal;
const
{ Cardinal takes more space, but is about 10% faster in 32-bit }
CrcTable: array[0..255] of Cardinal = (
$0000, $1021, $2042, $3063, $4084, $50a5, $60c6, $70e7,
$8108, $9129, $a14a, $b16b, $c18c, $d1ad, $e1ce, $f1ef,
$1231, $0210, $3273, $2252, $52b5, $4294, $72f7, $62d6,
$9339, $8318, $b37b, $a35a, $d3bd, $c39c, $f3ff, $e3de,
$2462, $3443, $0420, $1401, $64e6, $74c7, $44a4, $5485,
$a56a, $b54b, $8528, $9509, $e5ee, $f5cf, $c5ac, $d58d,
$3653, $2672, $1611, $0630, $76d7, $66f6, $5695, $46b4,
$b75b, $a77a, $9719, $8738, $f7df, $e7fe, $d79d, $c7bc,
$48c4, $58e5, $6886, $78a7, $0840, $1861, $2802, $3823,
$c9cc, $d9ed, $e98e, $f9af, $8948, $9969, $a90a, $b92b,
$5af5, $4ad4, $7ab7, $6a96, $1a71, $0a50, $3a33, $2a12,
$dbfd, $cbdc, $fbbf, $eb9e, $9b79, $8b58, $bb3b, $ab1a,
$6ca6, $7c87, $4ce4, $5cc5, $2c22, $3c03, $0c60, $1c41,
$edae, $fd8f, $cdec, $ddcd, $ad2a, $bd0b, $8d68, $9d49,
$7e97, $6eb6, $5ed5, $4ef4, $3e13, $2e32, $1e51, $0e70,
$ff9f, $efbe, $dfdd, $cffc, $bf1b, $af3a, $9f59, $8f78,
$9188, $81a9, $b1ca, $a1eb, $d10c, $c12d, $f14e, $e16f,
$1080, $00a1, $30c2, $20e3, $5004, $4025, $7046, $6067,
$83b9, $9398, $a3fb, $b3da, $c33d, $d31c, $e37f, $f35e,
$02b1, $1290, $22f3, $32d2, $4235, $5214, $6277, $7256,
$b5ea, $a5cb, $95a8, $8589, $f56e, $e54f, $d52c, $c50d,
$34e2, $24c3, $14a0, $0481, $7466, $6447, $5424, $4405,
$a7db, $b7fa, $8799, $97b8, $e75f, $f77e, $c71d, $d73c,
$26d3, $36f2, $0691, $16b0, $6657, $7676, $4615, $5634,
$d94c, $c96d, $f90e, $e92f, $99c8, $89e9, $b98a, $a9ab,
$5844, $4865, $7806, $6827, $18c0, $08e1, $3882, $28a3,
$cb7d, $db5c, $eb3f, $fb1e, $8bf9, $9bd8, $abbb, $bb9a,
$4a75, $5a54, $6a37, $7a16, $0af1, $1ad0, $2ab3, $3a92,
$fd2e, $ed0f, $dd6c, $cd4d, $bdaa, $ad8b, $9de8, $8dc9,
$7c26, $6c07, $5c64, $4c45, $3ca2, $2c83, $1ce0, $0cc1,
$ef1f, $ff3e, $cf5d, $df7c, $af9b, $bfba, $8fd9, $9ff8,
$6e17, $7e36, $4e55, $5e74, $2e93, $3eb2, $0ed1, $1ef0
);
const
Crc32Table : array[0..255] of DWORD = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f, $e963a535,
$9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988, $09b64c2b, $7eb17cbd,
$e7b82d07, $90bf1d91, $1db71064, $6ab020f2, $f3b97148, $84be41de, $1adad47d,
$6ddde4eb, $f4d4b551, $83d385c7, $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec,
$14015c4f, $63066cd9, $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4,
$a2677172, $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
$dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59, $26d930ac,
$51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423, $cfba9599, $b8bda50f,
$2802b89e, $5f058808, $c60cd9b2, $b10be924, $2f6f7c87, $58684c11, $c1611dab,
$b6662d3d, $76dc4190, $01db7106, $98d220bc, $efd5102a, $71b18589, $06b6b51f,
$9fbfe4a5, $e8b8d433, $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb,
$086d3d2d, $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
$6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950, $8bbeb8ea,
$fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65, $4db26158, $3ab551ce,
$a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7, $a4d1c46d, $d3d6f4fb, $4369e96a,
$346ed9fc, $ad678846, $da60b8d0, $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9,
$5005713c, $270241aa, $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409,
$ce61e49f, $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
$b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a, $ead54739,
$9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84, $0d6d6a3e, $7a6a5aa8,
$e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1, $f00f9344, $8708a3d2, $1e01f268,
$6906c2fe, $f762575d, $806567cb, $196c3671, $6e6b06e7, $fed41b76, $89d32be0,
$10da7a5a, $67dd4acc, $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8,
$a1d1937e, $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55, $316e8eef,
$4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236, $cc0c7795, $bb0b4703,
$220216b9, $5505262f, $c5ba3bbe, $b2bd0b28, $2bb45a92, $5cb36a04, $c2d7ffa7,
$b5d0cf31, $2cd99e8b, $5bdeae1d, $9b64c2b0, $ec63f226, $756aa39c, $026d930a,
$9c0906a9, $eb0e363f, $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae,
$0cb61b38, $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
$68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777, $88085ae6,
$ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69, $616bffd3, $166ccf45,
$a00ae278, $d70dd2ee, $4e048354, $3903b3c2, $a7672661, $d06016f7, $4969474d,
$3e6e77db, $aed16a4a, $d9d65adc, $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5,
$47b2cf7f, $30b5ffe9, $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605,
$cdd70693, $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
$b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
);
implementation
{$IFDEF TRIALRUN}
uses
StTrial;
{$ENDIF}
type
CRCByteArray = array[0..Pred(High(LongInt))] of Byte;
function Adler32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
{ Calculates the Adler 32-bit CRC of a block }
var
S1, S2, I : LongInt;
begin
if DataSize > 0 then begin
S1 := CurCrc and $FFFF;
S2 := (CurCrc shr 16) and $FFFF;
for I := 0 to (DataSize-1) do begin
S1 := (S1 + CRCByteArray(Data)[I]) mod 65521;
S2 := (S2 + S1) mod 65521;
end;
Result := (S2 shl 16) + S1;
end else
Result := CurCrc;
end;
function Adler32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
{ Calculates the Adler 32-bit CRC of a stream }
var
BufArray : array[0..(CrcBufSize-1)] of Byte;
Res : LongInt;
begin
{Initialize Crc}
Result := CurCrc;
repeat
Res := Stream.Read(BufArray, CrcBufSize);
Result := Adler32Prim(BufArray, Res, Result);
until (Res <> CrcBufSize);
end;
function Adler32OfFile(FileName : String) : LongInt;
{ Calculates the Adler 32-bit CRC of a file }
var
FileSt : TFileStream;
begin
FileSt := TFileStream.Create(FileName, CrcFileMode);
try
Result := Adler32OfStream(FileSt, 1);
finally
FileSt.Free;
end;
end;
function Crc16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
{ Calculates the 16-bit CRC of a block }
var
I : Integer;
begin
Result := CurCrc;
for I := 0 to (DataSize-1) do
Result := (CrcTable[((Result shr 8) and 255)] xor (Result shl 8) xor
CRCByteArray(Data)[I]) and $FFFF;
end;
function Crc16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
{ Calculates the 16-bit CRC of a stream }
var
BufArray : array[0..(CrcBufSize-1)] of Byte;
Res : LongInt;
begin
{Initialize Crc}
Result := CurCrc;
repeat
Res := Stream.Read(BufArray, CrcBufSize);
Result := Crc16Prim(BufArray, Res, Result);
until (Res <> CrcBufSize);
end;
function Crc16OfFile(FileName : String) : Cardinal;
{ Calculates the 16-bit CRC of a file }
var
FileSt : TFileStream;
begin
FileSt := TFileStream.Create(FileName, CrcFileMode);
try
Result := Crc16OfStream(FileSt, 0);
finally
FileSt.Free;
end;
end;
function Crc32Prim(var Data; DataSize : Cardinal; CurCrc : LongInt) : LongInt;
{ Calculates the 32-bit CRC of a block }
var
I : Integer;
begin
Result := CurCrc;
for I := 0 to (DataSize-1) do
Result := Crc32Table[Byte(Result xor CRCByteArray(Data)[I])] xor
DWord((Result shr 8) and $00FFFFFF);
end;
function Crc32OfStream(Stream : TStream; CurCrc : LongInt) : LongInt;
{ Calculates the 32-bit CRC of a stream }
var
BufArray : array[0..(CrcBufSize-1)] of Byte;
Res : LongInt;
begin
{Initialize Crc}
Result := CurCrc;
repeat
Res := Stream.Read(BufArray, CrcBufSize);
Result := Crc32Prim(BufArray, Res, Result);
until (Res <> CrcBufSize);
end;
function Crc32OfFile(FileName : String) : LongInt;
{ Calculates the 32-bit CRC of a file }
var
FileSt : TFileStream;
begin
FileSt := TFileStream.Create(FileName, CrcFileMode);
try
Result := not Crc32OfStream(FileSt, LongInt($FFFFFFFF));
finally
FileSt.Free;
end;
end;
function InternetSumPrim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
{ Calculates the Internet Checksum of a block }
var
I : Integer;
begin
Result := CurCrc;
if DataSize = 0 then Exit;
for I := 0 to (DataSize - 1) do begin
if Odd(I) then
Result := Result + (CRCByteArray(Data)[I] shl 8)
else
Result := Result + CRCByteArray(Data)[I];
end;
Result := (not((Result and $FFFF) + (Result shr 16))) and $FFFF;
end;
function InternetSumOfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
{ Calculates the Internet Checksum of a stream }
var
BufArray : array[0..(CrcBufSize-1)] of Byte;
Res : LongInt;
begin
{Initialize Crc}
Result := CurCrc;
repeat
Res := Stream.Read(BufArray, CrcBufSize);
Result := InternetSumPrim(BufArray, Res, Result);
until (Res <> CrcBufSize);
end;
function InternetSumOfFile(FileName : String) : Cardinal;
{ Calculates the Internet Checksum of a file }
var
FileSt : TFileStream;
begin
FileSt := TFileStream.Create(FileName, CrcFileMode);
try
Result := InternetSumOfStream(FileSt, 0);
finally
FileSt.Free;
end;
end;
function Kermit16Prim(var Data; DataSize, CurCrc : Cardinal) : Cardinal;
{ Calculates the Kermit 16-bit CRC of a block }
var
I, J : Integer;
Temp : Cardinal;
CurrByte : Byte;
begin
for I := 0 to (DataSize-1) do begin
CurrByte := CRCByteArray(Data)[I];
for J := 0 to 7 do begin
Temp := CurCrc xor CurrByte;
CurCrc := CurCrc shr 1;
if Odd(Temp) then
CurCrc := CurCrc xor $8408;
CurrByte := CurrByte shr 1;
end;
end;
Result := CurCrc;
end;
function Kermit16OfStream(Stream : TStream; CurCrc : Cardinal) : Cardinal;
{ Calculates the Kermit 16-bit CRC of a stream }
var
BufArray : array[0..(CrcBufSize-1)] of Byte;
Res : LongInt;
begin
{Initialize Crc}
Result := CurCrc;
repeat
Res := Stream.Read(BufArray, CrcBufSize);
Result := Kermit16Prim(BufArray, Res, Result);
until (Res <> CrcBufSize);
end;
function Kermit16OfFile(FileName : String) : Cardinal;
{ Calculates the Kermit 16-bit CRC of a file }
var
FileSt : TFileStream;
begin
FileSt := TFileStream.Create(FileName, CrcFileMode);
try
Result := Kermit16OfStream(FileSt, 0);
finally
FileSt.Free;
end;
end;
end.

965
components/systools/source/run/stdate.pas Normal file
View File

@ -0,0 +1,965 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDate.pas 4.04 *}
{*********************************************************}
{* SysTools: Date and time manipulation *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{For BCB 3.0 package support.}
{$IFDEF VER110}
{$ObjExportAll On}
{$ENDIF}
unit StDate;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils;
type
TStDate = LongInt;
{In STDATE, dates are stored in long integer format as the number of days
since January 1, 1600}
TDateArray = array[0..(MaxLongInt div SizeOf(TStDate))-1] of TStDate;
{Type for StDate open array}
TStDayType = (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);
{An enumerated type used when representing a day of the week}
TStBondDateType = (bdtActual, bdt30E360, bdt30360, bdt30360psa);
{An enumerated type used for calculating bond date differences}
TStTime = LongInt;
{STDATE handles time in a manner similar to dates, representing a given
time of day as the number of seconds since midnight}
TStDateTimeRec =
record
{This record type simply combines the two basic date types defined by
STDATE, Date and Time}
D : TStDate;
T : TStTime;
end;
const
MinYear = 1600; {Minimum valid year for a date variable}
MaxYear = 3999; {Maximum valid year for a date variable}
Mindate = $00000000; {Minimum valid date for a date variable - 01/01/1600}
Maxdate = $000D6025; {Maximum valid date for a date variable - 12/31/3999}
Date1900 : longint = $0001AC05; {Julian date for 01/01/1900}
Date1970 : longint = $00020FE4; {Julian date for 01/01/1970}
Date1980 : longint = $00021E28; {Julian date for 01/01/1980}
Date2000 : longint = $00023AB1; {Julian date for 01/01/2000}
Days400Yr : longint = 146097; {days in 400 years}
{This value is used to represent an invalid date, such as 12/32/1992}
BadDate = LongInt($FFFFFFFF);
DeltaJD = $00232DA8; {Days between 1/1/-4173 and 1/1/1600}
MinTime = 0; {Minimum valid time for a time variable - 00:00:00 am}
MaxTime = 86399; {Maximum valid time for a time variable - 23:59:59 pm}
{This value is used to represent an invalid time of day, such as 12:61:00}
BadTime = LongInt($FFFFFFFF);
SecondsInDay = 86400; {Number of seconds in a day}
SecondsInHour = 3600; {Number of seconds in an hour}
SecondsInMinute = 60; {Number of seconds in a minute}
HoursInDay = 24; {Number of hours in a day}
MinutesInHour = 60; {Number of minutes in an hour}
MinutesInDay = 1440; {Number of minutes in a day}
var
DefaultYear : Integer; {default year--used by DateStringToDMY}
DefaultMonth : ShortInt; {default month}
{-------julian date routines---------------}
function CurrentDate : TStDate;
{-returns today's date as a Julian date}
function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean;
{-Verify that day, month, year is a valid date}
function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate;
{-Convert from day, month, year to a Julian date}
procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer);
{-Convert from a Julian date to day, month, year}
function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate;
{-Add (or subtract) the number of days, months, and years to a date}
function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate;
{-Add (or subtract) the specified number of months and years to a date}
procedure DateDiff(Date1, Date2 : TStDate;
var Days, Months, Years : Integer);
{-Return the difference in days, months, and years between two valid Julian
dates}
function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate;
{-Return the difference in days between two valid Julian
dates using a specific financial basis}
function WeekOfYear(Julian : TStDate) : Byte;
{-Returns the week number of the year given the Julian Date}
function AstJulianDate(Julian : TStDate) : Double;
{-Returns the Astronomical Julian Date from a TStDate}
function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate;
{-Returns a TStDate from an Astronomical Julian Date.
Truncate TRUE Converts to appropriate 0 hours then truncates
FALSE Converts to appropriate 0 hours, then rounds to
nearest;}
function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double;
{-Returns an Astronomical Julian Date for any year, even those outside
MinYear..MaxYear}
function DayOfWeek(Julian : TStDate) : TStDayType;
{-Return the day of the week for a Julian date}
function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType;
{-Return the day of the week for the day, month, year}
function IsLeapYear(Year : Integer) : Boolean;
{-Return True if Year is a leap year}
function DaysInMonth(Month : Integer; Year, Epoch : Integer) : Integer;
{-Return the number of days in the specified month of a given year}
function ResolveEpoch(Year, Epoch : Integer) : Integer;
{-Convert 2 digit year to 4 digit year according to Epoch}
{-------time routines---------------}
function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean;
{-Return True if Hours:Minutes:Seconds is a valid time}
procedure StTimeToHMS(T : TStTime;
var Hours, Minutes, Seconds : Byte);
{-Convert a time variable to hours, minutes, seconds}
function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime;
{-Convert hours, minutes, seconds to a time variable}
function CurrentTime : TStTime;
{-Return the current time in seconds since midnight}
procedure TimeDiff(Time1, Time2 : TStTime;
var Hours, Minutes, Seconds : Byte);
{-Return the difference in hours, minutes, and seconds between two times}
function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
{-Add the specified hours, minutes, and seconds to a given time of day}
function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
{-Subtract the specified hours, minutes, and seconds from a given time of day}
function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime;
{-Given a time, round it to the nearest hour, or truncate minutes and
seconds}
function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime;
{-Given a time, round it to the nearest minute, or truncate seconds}
{-------- routines for DateTimeRec records ---------}
procedure DateTimeDiff(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
var Days : LongInt; var Secs : LongInt);
{-Return the difference in days and seconds between two points in time}
procedure IncDateTime(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
Days : Integer; Secs : LongInt);
{-Increment (or decrement) a date and time by the specified number of days
and seconds}
function DateTimeToStDate(DT : TDateTime) : TStDate;
{-Convert Delphi TDateTime to TStDate}
function DateTimeToStTime(DT : TDateTime) : TStTime;
{-Convert Delphi TDateTime to TStTime}
function StDateToDateTime(D : TStDate) : TDateTime;
{-Convert TStDate to TDateTime}
function StTimeToDateTime(T : TStTime) : TDateTime;
{-Convert TStTime to TDateTime}
function Convert2ByteDate(TwoByteDate : Word) : TStDate;
{-Convert an Object Professional two byte date into a SysTools date}
function Convert4ByteDate(FourByteDate : TStDate) : Word;
{-Convert a SysTools date into an Object Professional two byte date}
implementation
const
First2Months = 59; {1600 was a leap year}
FirstDayOfWeek = Saturday; {01/01/1600 was a Saturday}
DateLen = 40; {maximum length of Picture strings}
MaxMonthName = 15;
MaxDayName = 15;
//type
{ DateString = string[DateLen];}
// SString = string[255];
function IsLeapYear(Year : Integer) : Boolean;
{-Return True if Year is a leap year}
begin
Result := (Year mod 4 = 0) and (Year mod 4000 <> 0) and
((Year mod 100 <> 0) or (Year mod 400 = 0));
end;
function IsLastDayofMonth(Day, Month, Year : Integer) : Boolean;
{-Return True if date is the last day in month}
var
Epoch : Integer;
begin
Epoch := (Year div 100) * 100;
if ValidDate(Day + 1, Month, Year, Epoch) then
Result := false
else
Result := true;
end;
function IsLastDayofFeb(Date : TStDate) : Boolean;
{-Return True if date is the last day in February}
var
Day, Month, Year : Integer;
begin
StDateToDMY(Date, Day, Month, Year);
if (Month = 2) and IsLastDayOfMonth(Day, Month, Year) then
Result := true
else
Result := false;
end;
procedure ExchangeLongInts(var I, J : LongInt);
register;
asm
mov ecx, [eax]
push ecx
mov ecx, [edx]
mov [eax], ecx
pop ecx
mov [edx], ecx
end;
procedure ExchangeStructs(var I, J; Size : Cardinal);
register;
asm
push edi
push ebx
push ecx
shr ecx, 2
jz @@LessThanFour
@@AgainDWords:
mov ebx, [eax]
mov edi, [edx]
mov [edx], ebx
mov [eax], edi
add eax, 4
add edx, 4
dec ecx
jnz @@AgainDWords
@@LessThanFour:
pop ecx
and ecx, $3
jz @@Done
mov bl, [eax]
mov bh, [edx]
mov [edx], bl
mov [eax], bh
inc eax
inc edx
dec ecx
jz @@Done
mov bl, [eax]
mov bh, [edx]
mov [edx], bl
mov [eax], bh
inc eax
inc edx
dec ecx
jz @@Done
mov bl, [eax]
mov bh, [edx]
mov [edx], bl
mov [eax], bh
@@Done:
pop ebx
pop edi
end;
function ResolveEpoch(Year, Epoch : Integer) : Integer;
{-Convert 2-digit year to 4-digit year according to Epoch}
var
EpochYear,
EpochCent : Integer;
begin
if Word(Year) < 100 then begin
EpochYear := Epoch mod 100;
EpochCent := (Epoch div 100) * 100;
if (Year < EpochYear) then
Inc(Year,EpochCent+100)
else
Inc(Year,EpochCent);
end;
Result := Year;
end;
function CurrentDate : TStDate;
{-Returns today's date as a julian}
var
Year, Month, Date : Word;
begin
DecodeDate(Now,Year,Month,Date);
Result := DMYToStDate(Date,Month,Year,0);
end;
function DaysInMonth(Month : integer; Year, Epoch : Integer) : Integer;
{-Return the number of days in the specified month of a given year}
begin
Year := ResolveEpoch(Year, Epoch);
if (Year < MinYear) OR (Year > MaxYear) then
begin
Result := 0;
Exit;
end;
case Month of
1, 3, 5, 7, 8, 10, 12 :
Result := 31;
4, 6, 9, 11 :
Result := 30;
2 :
Result := 28+Ord(IsLeapYear(Year));
else
Result := 0;
end;
end;
function ValidDate(Day, Month, Year, Epoch : Integer) : Boolean;
{-Verify that day, month, year is a valid date}
begin
Year := ResolveEpoch(Year, Epoch);
if (Day < 1) or (Year < MinYear) or (Year > MaxYear) then
Result := False
else case Month of
1..12 :
Result := Day <= DaysInMonth(Month, Year, Epoch);
else
Result := False;
end
end;
function DMYtoStDate(Day, Month, Year, Epoch : Integer) : TStDate;
{-Convert from day, month, year to a julian date}
begin
Year := ResolveEpoch(Year, Epoch);
if not ValidDate(Day, Month, Year, Epoch) then
Result := BadDate
else if (Year = MinYear) and (Month < 3) then
if Month = 1 then
Result := Pred(Day)
else
Result := Day+30
else begin
if Month > 2 then
Dec(Month, 3)
else begin
Inc(Month, 9);
Dec(Year);
end;
Dec(Year, MinYear);
Result :=
((LongInt(Year div 100)*Days400Yr) div 4)+
((LongInt(Year mod 100)*1461) div 4)+
(((153*Month)+2) div 5)+Day+First2Months;
end;
end;
function WeekOfYear(Julian : TStDate) : Byte;
{-Returns the week number of the year given the Julian Date}
var
Day, Month, Year : Integer;
FirstJulian : TStDate;
begin
if (Julian < MinDate) or (Julian > MaxDate) then
begin
Result := 0;
Exit;
end;
Julian := Julian + 3 - ((6 + Ord(DayOfWeek(Julian))) mod 7);
StDateToDMY(Julian,Day,Month,Year);
FirstJulian := DMYToStDate(1,1,Year,0);
Result := 1 + (Julian - FirstJulian) div 7;
end;
function AstJulianDate(Julian : TStDate) : Double;
{-Returns the Astronomical Julian Date from a TStDate}
begin
{Subtract 0.5d since Astronomical JD starts at noon
while TStDate (with implied .0) starts at midnight}
Result := Julian - 0.5 + DeltaJD;
end;
function AstJulianDatePrim(Year, Month, Date : Integer; UT : TStTime) : Double;
var
A, B : integer;
LY,
GC : Boolean;
begin
Result := -MaxLongInt;
if (not (Month in [1..12])) or (Date < 1) then
Exit
else if (Month in [1, 3, 5, 7, 8, 10, 12]) and (Date > 31) then
Exit
else if (Month in [4, 6, 9, 11]) and (Date > 30) then
Exit
else if (Month = 2) then begin
LY := IsLeapYear(Year);
if ((LY) and (Date > 29)) or (not (LY) and (Date > 28)) then
Exit;
end else if ((UT < 0) or (UT >= SecondsInDay)) then
Exit;
if (Month <= 2) then begin
Year := Year - 1;
Month := Month + 12;
end;
A := abs(Year div 100);
if (Year > 1582) then
GC := True
else if (Year = 1582) then begin
if (Month > 10) then
GC := True
else if (Month < 10) then
GC := False
else begin
if (Date >= 15) then
GC := True
else
GC := False;
end;
end else
GC := False;
if (GC) then
B := 2 - A + abs(A div 4)
else
B := 0;
Result := Trunc(365.25 * (Year + 4716))
+ Trunc(30.6001 * (Month + 1))
+ Date + B - 1524.5
+ UT / SecondsInDay;
end;
function AstJulianDatetoStDate(AstJulian : Double; Truncate : Boolean) : TStDate;
{-Returns a TStDate from an Astronomical Julian Date.
Truncate TRUE Converts to appropriate 0 hours then truncates
FALSE Converts to appropriate 0 hours, then rounds to
nearest;}
begin
{Convert to TStDate, adding 0.5d for implied .0d of TStDate}
AstJulian := AstJulian + 0.5 - DeltaJD;
if (AstJulian < MinDate) OR (AstJulian > MaxDate) then
begin
Result := BadDate;
Exit;
end;
if Truncate then
Result := Trunc(AstJulian)
else
Result := Trunc(AstJulian + 0.5);
end;
procedure StDateToDMY(Julian : TStDate; var Day, Month, Year : Integer);
{-Convert from a julian date to month, day, year}
var
I, J : LongInt;
begin
if Julian = BadDate then begin
Day := 0;
Month := 0;
Year := 0;
end else if Julian <= First2Months then begin
Year := MinYear;
if Julian <= 30 then begin
Month := 1;
Day := Succ(Julian);
end else begin
Month := 2;
Day := Julian-30;
end;
end else begin
I := (4*LongInt(Julian-First2Months))-1;
J := (4*((I mod Days400Yr) div 4))+3;
Year := (100*(I div Days400Yr))+(J div 1461);
I := (5*(((J mod 1461)+4) div 4))-3;
Day := ((I mod 153)+5) div 5;
Month := I div 153;
if Month < 10 then
Inc(Month, 3)
else begin
Dec(Month, 9);
Inc(Year);
end;
Inc(Year, MinYear);
end;
end;
function IncDate(Julian : TStDate; Days, Months, Years : Integer) : TStDate;
{-Add (or subtract) the number of months, days, and years to a date.
Months and years are added before days. No overflow/underflow
checks are made}
var
Day, Month, Year, Day28Delta : Integer;
begin
StDateToDMY(Julian, Day, Month, Year);
Day28Delta := Day-28;
if Day28Delta < 0 then
Day28Delta := 0
else
Day := 28;
Inc(Year, Years);
Inc(Year, Months div 12);
Inc(Month, Months mod 12);
if Month < 1 then begin
Inc(Month, 12);
Dec(Year);
end
else if Month > 12 then begin
Dec(Month, 12);
Inc(Year);
end;
Julian := DMYtoStDate(Day, Month, Year,0);
if Julian <> BadDate then begin
Inc(Julian, Days);
Inc(Julian, Day28Delta);
end;
Result := Julian;
end;
function IncDateTrunc(Julian : TStDate; Months, Years : Integer) : TStDate;
{-Add (or subtract) the specified number of months and years to a date}
var
Day, Month, Year : Integer;
MaxDay, Day28Delta : Integer;
begin
StDateToDMY(Julian, Day, Month, Year);
Day28Delta := Day-28;
if Day28Delta < 0 then
Day28Delta := 0
else
Day := 28;
Inc(Year, Years);
Inc(Year, Months div 12);
Inc(Month, Months mod 12);
if Month < 1 then begin
Inc(Month, 12);
Dec(Year);
end
else if Month > 12 then begin
Dec(Month, 12);
Inc(Year);
end;
Julian := DMYtoStDate(Day, Month, Year,0);
if Julian <> BadDate then begin
MaxDay := DaysInMonth(Month, Year,0);
if Day+Day28Delta > MaxDay then
Inc(Julian, MaxDay-Day)
else
Inc(Julian, Day28Delta);
end;
Result := Julian;
end;
procedure DateDiff(Date1, Date2 : TStDate; var Days, Months, Years : Integer);
{-Return the difference in days,months,years between two valid julian dates}
var
Day1, Day2, Month1, Month2, Year1, Year2 : Integer;
begin
{we want Date2 > Date1}
if Date1 > Date2 then
ExchangeLongInts(Date1, Date2);
{convert dates to day,month,year}
StDateToDMY(Date1, Day1, Month1, Year1);
StDateToDMY(Date2, Day2, Month2, Year2);
{days first}
if (Day1 = DaysInMonth(Month1, Year1, 0)) then begin
Day1 := 0;
Inc(Month1); {OK if Month1 > 12}
end;
if (Day2 = DaysInMonth(Month2, Year2, 0)) then begin
Day2 := 0;
Inc(Month2); {OK if Month2 > 12}
end;
if (Day2 < Day1) then begin
Dec(Month2);
if Month2 = 0 then begin
Month2 := 12;
Dec(Year2);
end;
Days := Day2 + DaysInMonth(Month2, Year2, 0) - Day1; {!!.02}
end else
Days := Day2-Day1;
{now months and years}
if Month2 < Month1 then begin
Inc(Month2, 12);
Dec(Year2);
end;
Months := Month2-Month1;
Years := Year2-Year1;
end;
function BondDateDiff(Date1, Date2 : TStDate; DayBasis : TStBondDateType) : TStDate;
{-Return the difference in days between two valid Julian
dates using one a specific accrual method}
var
Day1,
Month1,
Year1,
Day2,
Month2,
Year2 : Integer;
IY : LongInt;
begin
{we want Date2 > Date1}
if Date1 > Date2 then
ExchangeLongInts(Date1, Date2);
if (DayBasis = bdtActual) then
Result := Date2-Date1
else
begin
StDateToDMY(Date1, Day1, Month1, Year1);
StDateToDMY(Date2, Day2, Month2, Year2);
if ((DayBasis = bdt30360PSA) and IsLastDayofFeb(Date1)) or (Day1 = 31) then
Day1 := 30;
if (DayBasis = bdt30E360) then
begin
if (Day2 = 31) then
Day2 := 30
end else
if (Day2 = 31) and (Day1 >= 30) then
Day2 := 30;
IY := 360 * (Year2 - Year1);
Result := IY + 30 * (Month2 - Month1) + (Day2 - Day1);
end;
end;
function DayOfWeek(Julian : TStDate) : TStDayType;
{-Return the day of the week for the date. Returns TStDayType(7) if Julian =
BadDate.}
var
B : Byte;
begin
if Julian = BadDate then begin
B := 7;
Result := TStDayType(B);
end else
Result := TStDayType( (Julian+Ord(FirstDayOfWeek)) mod 7 );
end;
function DayOfWeekDMY(Day, Month, Year, Epoch : Integer) : TStDayType;
{-Return the day of the week for the day, month, year}
begin
Result := DayOfWeek( DMYtoStDate(Day, Month, Year, Epoch) );
end;
procedure StTimeToHMS(T : TStTime; var Hours, Minutes, Seconds : Byte);
{-Convert a Time variable to Hours, Minutes, Seconds}
begin
if T = BadTime then begin
Hours := 0;
Minutes := 0;
Seconds := 0;
end
else begin
Hours := T div SecondsInHour;
Dec(T, LongInt(Hours)*SecondsInHour);
Minutes := T div SecondsInMinute;
Dec(T, LongInt(Minutes)*SecondsInMinute);
Seconds := T;
end;
end;
function HMStoStTime(Hours, Minutes, Seconds : Byte) : TStTime;
{-Convert Hours, Minutes, Seconds to a Time variable}
var
T : TStTime;
begin
Hours := Hours mod HoursInDay;
T := (LongInt(Hours)*SecondsInHour)+(LongInt(Minutes)*SecondsInMinute)+Seconds;
Result := T mod SecondsInDay;
end;
function ValidTime(Hours, Minutes, Seconds : Integer) : Boolean;
{-Return true if Hours:Minutes:Seconds is a valid time}
begin
if (Hours < 0) or (Hours > 23) or
(Minutes < 0) or (Minutes >= 60) or
(Seconds < 0) or (Seconds >= 60) then
Result := False
else
Result := True;
end;
function CurrentTime : TStTime;
{-Returns current time in seconds since midnight}
begin
Result := Trunc(SysUtils.Time * SecondsInDay);
end;
procedure TimeDiff(Time1, Time2 : TStTime; var Hours, Minutes, Seconds : Byte);
{-Return the difference in hours,minutes,seconds between two times}
begin
StTimeToHMS(Abs(Time1-Time2), Hours, Minutes, Seconds);
end;
function IncTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
{-Add the specified hours,minutes,seconds to T and return the result}
begin
Inc(T, HMStoStTime(Hours, Minutes, Seconds));
Result := T mod SecondsInDay;
end;
function DecTime(T : TStTime; Hours, Minutes, Seconds : Byte) : TStTime;
{-Subtract the specified hours,minutes,seconds from T and return the result}
begin
Hours := Hours mod HoursInDay;
Dec(T, HMStoStTime(Hours, Minutes, Seconds));
if T < 0 then
Result := T+SecondsInDay
else
Result := T;
end;
function RoundToNearestHour(T : TStTime; Truncate : Boolean) : TStTime;
{-Round T to the nearest hour, or Truncate minutes and seconds from T}
var
Hours, Minutes, Seconds : Byte;
begin
StTimeToHMS(T, Hours, Minutes, Seconds);
Seconds := 0;
if not Truncate then
if Minutes >= (MinutesInHour div 2) then
Inc(Hours);
Minutes := 0;
Result := HMStoStTime(Hours, Minutes, Seconds);
end;
function RoundToNearestMinute(const T : TStTime; Truncate : Boolean) : TStTime;
{-Round T to the nearest minute, or Truncate seconds from T}
var
Hours, Minutes, Seconds : Byte;
begin
StTimeToHMS(T, Hours, Minutes, Seconds);
if not Truncate then
if Seconds >= (SecondsInMinute div 2) then
Inc(Minutes);
Seconds := 0;
Result := HMStoStTime(Hours, Minutes, Seconds);
end;
procedure DateTimeDiff(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
var Days : LongInt; var Secs : LongInt);
{-Return the difference in days and seconds between two points in time}
var
tDT1, tDT2 : TStDateTimeRec;
begin
tDT1 := DT1;
tDT2 := DT2;
{swap if tDT1 later than tDT2}
if (tDT1.D > tDT2.D) or ((tDT1.D = tDT2.D) and (tDT1.T > tDT2.T)) then
ExchangeStructs(tDT1, tDT2,sizeof(TStDateTimeRec));
{the difference in days is easy}
Days := tDT2.D-tDT1.D;
{difference in seconds}
if tDT2.T < tDT1.T then begin
{subtract one day, add 24 hours}
Dec(Days);
Inc(tDT2.T, SecondsInDay);
end;
Secs := tDT2.T-tDT1.T;
end;
function DateTimeToStDate(DT : TDateTime) : TStDate;
{-Convert Delphi TDateTime to TStDate}
var
Day, Month, Year : Word;
begin
DecodeDate(DT, Year, Month, Day);
Result := DMYToStDate(Day, Month, Year, 0);
end;
function DateTimeToStTime(DT : TDateTime) : TStTime;
{-Convert Delphi TDateTime to TStTime}
var
Hour, Min, Sec, MSec : Word;
begin
DecodeTime(DT, Hour, Min, Sec, MSec);
Result := HMSToStTime(Hour, Min, Sec);
end;
function StDateToDateTime(D : TStDate) : TDateTime;
{-Convert TStDate to TDateTime}
var
Day, Month, Year : Integer;
begin
Result := 0;
if D <> BadDate then begin
StDateToDMY(D, Day, Month, Year);
Result := EncodeDate(Year, Month, Day);
end;
end;
function StTimeToDateTime(T : TStTime) : TDateTime;
{-Convert TStTime to TDateTime}
var
Hour, Min, Sec : Byte;
begin
Result := 0;
if T <> BadTime then begin
StTimeToHMS(T, Hour, Min, Sec);
Result := EncodeTime(Hour, Min, Sec, 0);
end;
end;
procedure IncDateTime(const DT1 : TStDateTimeRec; var DT2 : TStDateTimeRec; {!!.02}
Days : Integer; Secs : LongInt);
{-Increment (or decrement) DT1 by the specified number of days and seconds
and put the result in DT2}
begin
DT2 := DT1;
{date first}
Inc(DT2.D, LongInt(Days));
if Secs < 0 then begin
{change the sign}
Secs := -Secs;
{adjust the date}
Dec(DT2.D, Secs div SecondsInDay);
Secs := Secs mod SecondsInDay;
if Secs > DT2.T then begin
{subtract a day from DT2.D and add a day's worth of seconds to DT2.T}
Dec(DT2.D);
Inc(DT2.T, SecondsInDay);
end;
{now subtract the seconds}
Dec(DT2.T, Secs);
end
else begin
{increment the seconds}
Inc(DT2.T, Secs);
{adjust date if necessary}
Inc(DT2.D, DT2.T div SecondsInDay);
{force time to 0..SecondsInDay-1 range}
DT2.T := DT2.T mod SecondsInDay;
end;
end;
function Convert2ByteDate(TwoByteDate : Word) : TStDate;
begin
Result := LongInt(TwoByteDate) + Date1900;
end;
function Convert4ByteDate(FourByteDate : TStDate) : Word;
begin
Result := Word(FourByteDate - Date1900);
end;
procedure SetDefaultYear;
{-Initialize DefaultYear and DefaultMonth}
var
Month, Day, Year : Word;
T : TDateTime;
begin
T := Now;
DecodeDate(T, Year, Month, Day);
DefaultYear := Year;
DefaultMonth := Month;
end;
initialization
{initialize DefaultYear and DefaultMonth}
SetDefaultYear;
end.

1111
components/systools/source/run/stdatest.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1308
components/systools/source/run/stdecmth.pas Normal file
View File

File diff suppressed because it is too large Load Diff

886
components/systools/source/run/stdict.pas Normal file
View File

@ -0,0 +1,886 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StDict.pas 4.04 *}
{*********************************************************}
{* SysTools: Dictionary class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{Notes:
Nodes stored in the dictionary must be of type TStDictNode.
Duplicate strings are not allowed in the dictionary.
Calling Exists moves the found node to the front of its hash bin list.
Iterate scans the nodes in hash order.
Hashing and comparison is case-insensitive by default.
In 16-bit mode, HashSize must be in the range 1..16380. In 32-bit
mode, there is no practical limit on HashSize. A particular value
of HashSize may lead to a better distribution of symbols in the
dictionary, and therefore to better performance. Generally HashSize
should be about the same size as the number of symbols expected in
the dictionary. A prime number tends to give a better distribution.
Based on analysis by D. Knuth, the following values are good
choices for HashSize when the dictionary keys are alphanumeric
strings:
59 61 67 71 73 127 131 137 191 193 197 199 251 257 263 311 313
317 379 383 389 439 443 449 457 503 509 521 569 571 577 631 641
643 647 701 709 761 769 773 823 827 829 839 887 953 967
Good values for larger tables can be computed by the GOODHASH.PAS
bonus program.
}
unit StDict;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes,
StConst, StBase;
type
TStDictNode = class(TStNode)
{.Z+}
protected
dnNext : TStDictNode; {Next node in hash list}
dnName : string; {Name of symbol, already a pointer}
function GetName : string;
{.Z-}
public
constructor CreateStr(const Name : string; AData : Pointer);
{-Initialize node}
destructor Destroy; override;
{-Free name string and destroy node}
property Name : string
read GetName;
end;
{.Z+}
TSymbolArray = array[0..(StMaxBlockSize div SizeOf(TStDictNode))-1] of TStDictNode;
PSymbolArray = ^TSymbolArray;
{.Z-}
TDictHashFunc =
function(const S : AnsiString; Size : Integer) : Integer;
TStDictionary = class(TStContainer)
{.Z+}
protected
{property instance variables}
FHashSize : Integer; {Bins in symbol array}
FEqual : TStringCompareFunc; {String compare function}
FHash : TDictHashFunc;
{event variables}
FOnEqual : TStStringCompareEvent;
{private instance variables}
dySymbols : PSymbolArray; {Pointer to symbol array}
dyIgnoreDups : Boolean; {Ignore duplicates during Join?}
{protected undocumented methods}
procedure dySetEqual(E : TStringCompareFunc);
procedure dySetHash(H : TDictHashFunc);
procedure dySetHashSize(Size : Integer);
procedure dyFindNode(const Name : string; var H : Integer;
var Prev, This : TStDictNode);
{.Z-}
public
constructor Create(AHashSize : Integer); virtual;
{-Initialize an empty dictionary}
destructor Destroy; override;
{-Destroy a dictionary}
procedure LoadFromStream(S : TStream); override;
{-Read a dictionary and its data from a stream}
procedure StoreToStream(S : TStream); override;
{-Write a dictionary and its data to a stream}
procedure Clear; override;
{-Remove all nodes from container but leave it instantiated}
function DoEqual(const String1, String2 : string) : Integer;
virtual;
function Exists(const Name : string; var Data : Pointer) : Boolean;
{-Return True and the Data pointer if Name is in the dictionary}
procedure Add(const Name : string; Data : Pointer);
{-Add new Name and Data to the dictionary}
procedure Delete(const Name : string);
{-Delete a Name from the dictionary}
procedure GetItems(S : TStrings);
{-Fill the string list with all stored strings}
procedure SetItems(S : TStrings);
{-Fill the container with the strings and objects in S}
procedure Update(const Name : string; Data : Pointer);
{-Update the data for an existing element}
function Find(Data : Pointer; var Name : string) : Boolean;
{-Return True and the element Name that matches Data}
procedure Assign(Source: TPersistent); override;
{-Assign another container's contents to this one}
procedure Join(D : TStDictionary; IgnoreDups : Boolean);
{-Add dictionary D into this one and dispose D}
function Iterate(Action : TIterateFunc;
OtherData : Pointer) : TStDictNode;
{-Call Action for all the nodes, returning the last node visited}
function BinCount(H : Integer) : LongInt;
{-Return number of names in a hash bin (for testing)}
property Equal : TStringCompareFunc
read FEqual
write dySetEqual;
property Hash : TDictHashFunc
read FHash
write dySetHash;
property HashSize : Integer
read FHashSize
write dySetHashSize;
property OnEqual : TStStringCompareEvent
read FOnEqual
write FOnEqual;
end;
function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
{-Case-insensitive hash function that uses the current language driver}
function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
{-Case-sensitive hash function}
function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
{-Case-insensitive ELF hash function that uses the current language driver}
function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
{-Case-sensitive ELF hash function}
implementation
{$IFDEF UNICODE}
uses
AnsiStrings;
{$ENDIF}
{$IFDEF ThreadSafe}
var
ClassCritSect : TRTLCriticalSection;
{$ENDIF}
procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;
procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;
{The following routine was extracted from LockBox and modified}
function HashElf(const Buf; BufSize : LongInt) : LongInt;
var
// Bytes : TByteArray absolute Buf; {!!.02}
Bytes : PAnsiChar; {!!.02}
I, X : LongInt;
begin
Bytes := @Buf; {!!.02}
Result := 0;
for I := 0 to BufSize - 1 do begin
Result := (Result shl 4) + Ord(Bytes^); {!!.02}
Inc(Bytes); {!!.02}
X := LongInt(Result and $F0000000); {!!.02}
if (X <> 0) then
Result := Result xor (X shr 24);
Result := Result and (not X);
end;
end;
function AnsiELFHashText(const S : AnsiString; Size : Integer) : Integer;
begin
{$IFDEF WStrings}
Result := AnsiELFHashStr(AnsiUpperCaseShort32(S), Size);
{$ELSE}
Result := AnsiELFHashStr(AnsiUpperCase(S), Size);
{$ENDIF}
end;
function AnsiELFHashStr(const S : AnsiString; Size : Integer) : Integer;
begin
Result := HashElf(S[1], Length(S)) mod Size;
if Result < 0 then
Inc(Result, Size);
end;
constructor TStDictNode.CreateStr(const Name : string; AData : Pointer);
begin
Create(AData);
dnName := Name;
end;
destructor TStDictNode.Destroy;
begin
dnName := '';
inherited Destroy;
end;
function TStDictNode.GetName : string;
begin
Result := dnName;
end;
function AnsiHashStr(const S : AnsiString; Size : Integer) : Integer;
{32-bit huge string}
register;
asm
push ebx
push esi
push edi
mov esi,S
mov edi,Size
xor ebx,ebx {ebx will be hash}
or esi,esi {empty literal string comes in as a nil pointer}
jz @2
mov edx,[esi-4] {edx = length}
or edx,edx {length zero?}
jz @2
xor ecx,ecx {ecx is shift counter}
@1:xor eax,eax
mov al,[esi] {eax = character}
inc esi
rol eax,cl {rotate character}
xor ebx,eax {xor with hash}
inc ecx {increment shift counter (rol uses only bottom 5 bits)}
dec edx
jnz @1
@2:mov eax,ebx
xor edx,edx
div edi {edi = Size}
mov eax,edx {return hash mod size}
pop edi
pop esi
pop ebx
end;
function AnsiHashText(const S : AnsiString; Size : Integer) : Integer;
begin
{$IFDEF WStrings}
Result := AnsiHashStr(AnsiUpperCaseShort32(S), Size);
{$ELSE}
Result := AnsiHashStr(AnsiUpperCase(S), Size);
{$ENDIF}
end;
function FindNodeData(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
begin
Result := (OtherData <> Node.Data);
end;
function JoinNode(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
H : Integer;
P, T : TStDictNode;
begin
Result := True;
with TStDictionary(OtherData) do begin
dyFindNode(TStDictNode(Node).dnName, H, P, T);
if Assigned(T) then
if dyIgnoreDups then begin
Node.Free;
Exit;
end else
RaiseContainerError(stscDupNode);
T := dySymbols^[H];
dySymbols^[H] := TStDictNode(Node);
dySymbols^[H].dnNext := T;
Inc(FCount);
end;
end;
function AssignNode(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
DictNode : TStDictNode absolute Node;
OurDict : TStDictionary absolute OtherData;
begin
OurDict.Add(DictNode.Name, DictNode.Data);
Result := true;
end;
{----------------------------------------------------------------------}
procedure TStDictionary.Add(const Name : string; Data : Pointer);
var
H : Integer;
P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
dyFindNode(Name, H, P, T);
if Assigned(T) then
RaiseContainerError(stscDupNode);
T := dySymbols^[H];
dySymbols^[H] := TStDictNode.CreateStr(Name, Data);
dySymbols^[H].dnNext := T;
Inc(FCount);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.Assign(Source: TPersistent);
var
i : integer;
begin
{The only two containers that we allow to be assigned to a string
dictionary are (1) another string dictionary and (2) a Delphi string
list (TStrings)}
if (Source is TStDictionary) then
begin
Clear;
TStDictionary(Source).Iterate(AssignNode, Self);
end
else if (Source is TStrings) then
begin
Clear;
for i := 0 to pred(TStrings(Source).Count) do
Add(TStrings(Source).Strings[i], TStrings(Source).Objects[i]);
end
else
inherited Assign(Source);
end;
function TStDictionary.BinCount(H : Integer) : LongInt;
var
C : LongInt;
T : TStDictNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
C := 0;
T := dySymbols^[H];
while Assigned(T) do begin
inc(C);
T := T.dnNext;
end;
Result := C;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.Clear;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if FCount <> 0 then begin
Iterate(DestroyNode, nil);
FCount := 0;
FillChar(dySymbols^, LongInt(FHashSize)*SizeOf(TStDictNode), 0);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
constructor TStDictionary.Create(AHashSize : Integer);
begin
CreateContainer(TStDictNode, 0);
{FHashSize := 0;}
{$IFDEF WStrings}
FEqual := AnsiCompareTextShort32;
{$ELSE}
FEqual := AnsiCompareText;
{$ENDIF}
FHash := AnsiHashText;
HashSize := AHashSize;
end;
procedure TStDictionary.Delete(const Name : string);
var
H : Integer;
P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
dyFindNode(Name, H, P, T);
if Assigned(T) then begin
if Assigned(P) then
P.dnNext := T.dnNext
else
dySymbols^[H] := T.dnNext;
DestroyNode(Self, T, nil);
Dec(FCount);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
destructor TStDictionary.Destroy;
begin
if conNodeProt = 0 then
Clear;
if Assigned(dySymbols) then
FreeMem(dySymbols, LongInt(FHashSize)*SizeOf(TStDictNode));
IncNodeProtection;
inherited Destroy;
end;
function TStDictionary.DoEqual(const String1, String2 : string) : Integer;
begin
Result := 0;
if Assigned(FOnEqual) then
FOnEqual(Self, String1, String2, Result)
else if Assigned(FEqual) then
Result := FEqual(String1, String2);
end;
procedure TStDictionary.dyFindNode(const Name : string; var H : Integer;
var Prev, This : TStDictNode);
var
P, T : TStDictNode;
begin
Prev := nil;
This := nil;
H := Hash(Name, HashSize);
T := dySymbols^[H];
P := nil;
while Assigned(T) do begin
if DoEqual(Name, T.dnName) = 0 then begin
Prev := P;
This := T;
Exit;
end;
P := T;
T := T.dnNext;
end;
{Not found}
This := nil;
end;
procedure TStDictionary.dySetEqual(E : TStringCompareFunc);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
FEqual := E;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.dySetHash(H : TDictHashFunc);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
FHash := H;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.dySetHashSize(Size : Integer);
var
H, OldSize : Integer;
TableSize : LongInt;
T, N : TStDictNode;
OldSymbols : PSymbolArray;
OldDisposeData : TDisposeDataProc;
OldOnDisposeData : TStDisposeDataEvent;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
TableSize := LongInt(Size)*SizeOf(TStDictNode);
if (Size <= 0) {or (TableSize > MaxBlockSize)} then
RaiseContainerError(stscBadSize);
if Size <> FHashSize then begin
OldSymbols := dySymbols;
OldSize := FHashSize;
{Get a new hash table}
GetMem(dySymbols, TableSize);
FillChar(dySymbols^, TableSize, 0);
FCount := 0;
FHashSize := Size;
if OldSize <> 0 then begin
{Prevent disposing of the user data while transferring elements}
OldDisposeData := DisposeData;
DisposeData := nil;
OldOnDisposeData := OnDisposeData;
OnDisposeData := nil;
{Add old symbols into new hash table}
for H := 0 to OldSize-1 do begin
T := OldSymbols^[H];
while Assigned(T) do begin
Add(T.dnName, T.Data);
N := T.dnNext;
{free the node just transferred}
T.Free;
T := N;
end;
end;
{Dispose of old hash table}
FreeMem(OldSymbols, OldSize*SizeOf(TStDictNode));
{Reassign the dispose data routine}
DisposeData := OldDisposeData;
OnDisposeData := OldOnDisposeData;
end;
{FHashSize := Size;}
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStDictionary.Exists(const Name : String; var Data : Pointer) : Boolean;
var
H : Integer;
P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
dyFindNode(Name, H, P, T);
if Assigned(T) then begin
if Assigned(P) then begin
{Move T to front of list}
P.dnNext := T.dnNext;
T.dnNext := dySymbols^[H];
dySymbols^[H] := T;
end;
Result := True;
Data := T.Data;
end else
Result := False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStDictionary.Find(Data : Pointer; var Name : string) : Boolean;
var
T : TStDictNode;
begin
Name := '';
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
T := Iterate(FindNodeData, Data);
if Assigned(T) then begin
Result := True;
Name := T.dnName;
end else
Result := False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.GetItems(S : TStrings);
var
H : Integer;
T : TStDictNode;
begin
S.Clear;
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if FCount <> 0 then begin
for H := 0 to FHashSize-1 do begin
T := dySymbols^[H];
while Assigned(T) do begin
S.AddObject(T.Name, T.Data);
T := T.dnNext;
end;
end;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.SetItems(S : TStrings);
var
I : Integer;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Clear;
for I := 0 to S.Count-1 do
Add(S.Strings[I], S.Objects[I]);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStDictionary.Iterate(Action : TIterateFunc;
OtherData : Pointer) : TStDictNode;
var
H : Integer;
T, N : TStDictNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if FCount <> 0 then begin
for H := 0 to FHashSize-1 do begin
T := dySymbols^[H];
while Assigned(T) do begin
N := T.dnNext;
if Action(Self, T, OtherData) then
T := N
else begin
Result := T;
Exit;
end;
end;
end;
end;
Result := nil;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.Join(D : TStDictionary; IgnoreDups : Boolean);
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
D.EnterCS;
try
{$ENDIF}
dyIgnoreDups := IgnoreDups;
D.Iterate(JoinNode, Self);
{Dispose of D, but not its nodes}
D.IncNodeProtection;
D.Free;
{$IFDEF ThreadSafe}
finally
D.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
procedure TStDictionary.Update(const Name : string; Data : Pointer);
var
H : Integer;
P, T : TStDictNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
dyFindNode(Name, H, P, T);
if Assigned(T) then
T.Data := Data;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.LoadFromStream(S : TStream);
var
Data : pointer;
Reader : TReader;
StreamedClass : TPersistentClass;
StreamedNodeClass : TPersistentClass;
StreamedClassName : string;
StreamedNodeClassName : string;
St : string;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Clear;
Reader := TReader.Create(S, 1024);
try
with Reader do
begin
StreamedClassName := ReadString;
StreamedClass := GetClass(StreamedClassName);
if (StreamedClass = nil) then
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
if (StreamedClass <> Self.ClassType) then
RaiseContainerError(stscWrongClass);
StreamedNodeClassName := ReadString;
StreamedNodeClass := GetClass(StreamedNodeClassName);
if (StreamedNodeClass = nil) then
RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
if (StreamedNodeClass <> conNodeClass) then
RaiseContainerError(stscWrongNodeClass);
HashSize := ReadInteger;
ReadListBegin;
while not EndOfList do
begin
St := ReadString;
Data := DoLoadData(Reader);
Add(St, Data);
end;
ReadListEnd;
end;
finally
Reader.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStDictionary.StoreToStream(S : TStream);
var
H : Integer;
Walker : TStDictNode;
Writer : TWriter;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Writer := TWriter.Create(S, 1024);
try
with Writer do
begin
WriteString(Self.ClassName);
WriteString(conNodeClass.ClassName);
WriteInteger(HashSize);
WriteListBegin;
if (Count <> 0) then
for H := 0 to FHashSize-1 do
begin
Walker := dySymbols^[H];
while Assigned(Walker) do
begin
WriteString(Walker.dnName);
DoStoreData(Writer, Walker.Data);
Walker := Walker.dnNext;
end;
end;
WriteListEnd;
end;
finally
Writer.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
{$IFDEF ThreadSafe}
initialization
Windows.InitializeCriticalSection(ClassCritSect);
finalization
Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.

1660
components/systools/source/run/stexpr.pas Normal file
View File

File diff suppressed because it is too large Load Diff

355
components/systools/source/run/stexpr.txt Normal file
View File

@ -0,0 +1,355 @@
This file documents the TStExpression and TStExpressionEdit components.
TStExpression
=============
TStExpression is a non-visual component that provides expression evaluation
at several different levels. At the lowest level, simple mathematical
expressions can be evaluated and the resulting value obtained. On a higher
level, you can define alpha-numeric constants that can then be used within
expressions; You can add user-defined functions (and even methods of a class)
so that the names of these routines can be used in expressions; You can
define variables that relate directly to variables in your program and even
use them in expressions.
Note: TStExpression replaces AnalyzeExpr that SysTools version 2.00 provided,
but a version of that routine is still provided for backward compatibility.
The TStExpression expression parser implements the following grammar, similar
to a subset of Pascal:
expression: term | expression+term | expression-term
term: factor | term*factor | term/factor
factor: base | base^factor
base: unsigned_num | (expression) | sign factor | func_call
unsigned_num: digit_seq | digit_seq.digit_seq | digit_seq scale_fac |
digit_seq.digit_seq scale_fac
sign: + | -
func_call: identifier | identifier(params)
params: expression | params,expression
scale_fac: E digit_seq | E sign digit_seq
digit_seq: digit | digit_seq digit
identifier: starts with A..Z,_ continues with A..Z,_,0..9
digit: 0..9
Case is not significant when matching characters.
The grammar follows normal rules of arithmetic precedence, with ^ highest, *
and / in the middle, and + and - lowest. Thus, 1+2*3^4 means 1+(2*(3^4)).
Parentheses can be used to force non-default precedence.
Note that the power operator x^y is right-associative. This means that
2^0.5^2 is equivalent to 2^(0.5^2). All other arithmetic operators are left
associative: 1-2-3 is equivalent to (1-2)-3.
The following functions are supported in 16-bit and 32-bit applications:
abs, arctan, cos, exp, frac, int(trunc), ln, pi, round, sin, sqr,
sqrt
If the VCL Math unit is available and you define the "UseMathUnit" define in
STDEFINE.INC, the following are also available:
arccos, arcsin, arctan2, tan, cotan, hypot, cosh, sinh, tanh,
arccosh, arcsinh, arctanh, lnxp1, log10, log2, logn, ceil, floor
The calling conventions for all functions match those of the VCL runtime
library or Math unit. The acceptable parameter ranges and output values also
match thoses of the VCL runtime library or MATH unit.
When the input expression contains an error, TStExpression raises an
exception of type EStExprError. Its ErrorCode property provides more detail
about the error. Its ErrorColumn property gives the string index of the start
of the token where the error was detected.
TStExpression is very flexible. You can add support for your own functions
easily. For example, to add support for the Sin() function, first write a
function to provide the proper number and type of parameters (the "far" can
be omitted with 32-bit compilers):
function _Sin(Value : TStFloat) : TStFloat; far;
begin
Result := Sin(Value);
end;
and then add it to the TStExpression component:
MyStExpression.AddFunction1Param('sin', _Sin);
Or, if you wanted to use a method of the form (or any other class) that you
were working in, you could do the same thing this way:
function MyForm._Sin(Value : TStFloat) : TStFloat;
begin
Result := Sin(Value);
end;
and then add it to the TStExpression component:
MyStExpression.AddMethod1Param('sin', _Sin);
TStExpression supports user-defined functions with 0 to 3 parameters. The
parameters and function result must be the TStFloat type (defined in the
STBASE unit). In the example above, that's why we didn't just add
the Sin() function directly, in the call to AddFunction1Param -- The
TStExpression component must know the data types of parameters and return
values. If the function you are adding has no parameters, use the
AddFunction0Parm() method. AddFunction2Param for functions with two
parameters, etc.
The following function and method types define all possible user-defined
function and method types accepted by the TStExpression component:
{user-defined functions with up to 3 parameters}
TStFunction0Param =
function : TStFloat;
TStFunction1Param =
function(Value1 : TStFloat) : TStFloat;
TStFunction2Param =
function(Value1, Value2 : TStFloat) : TStFloat;
TStFunction3Param =
function(Value1, Value2, Value3 : TStFloat) : TStFloat;
{user-defined methods with up to 3 parameters}
TStMethod0Param =
function : TStFloat
of object;
TStMethod1Param =
function(Value1 : TStFloat) : TStFloat
of object;
TStMethod2Param =
function(Value1, Value2 : TStFloat) : TStFloat
of object;
TStMethod3Param =
function(Value1, Value2, Value3 : TStFloat) : TStFloat
of object;
Add predefined constant values by using the AddConstant method:
AddConstant('X', 50)
Then, in any expression that uses the identifier "X", the value 50 will be
used when the expression is evaluated.
Add references to variables in your program by using the AddVariable method:
var
MyVar : TStFloat;
AddVariable('MyVar', @MyVar);
Whenever an expression is evaluated that contains the "MyVar" identifier,
the actual value of the variable (in your program) is retrieved and used
to compute the expression result. Changes to variable's value in your
program will be reflected when the expression is next evaluated.
Two things to note: First, the variable must be a TStFloat type and second,
the variable must remain in "scope". In general, this means that the variable
must either be defined globally or as a class variable. You normally would not
use AddVariable for variables defined local to a procedure or function (a
stack variable).
TStExpression offers a way to dynamically determine the value of an variable
or function that is being used in an expression -- the OnGetIdentValue event.
This event is fired if the expression parser is unable to locate the identifier
in its internal list of identifier names. In response to the event, you should
assign a value to the Value parameter that corresponds to the identifier name
passed to the event as the Identifier parameter. If no event handler is
assigned to this even and the expression parser is unable to locate a match for
an identifier used in an expression, an exception is raised.
Reference Section
-----------------
methods
-------
function AnalyzeExpression : TStFloat;
-> AnalyzeExpression causes the expression contained in the Expression property
to be evaluated and returns the resulting value as the function result.
procedure AddConstant(const Name : string; Value : TStFloat);
-> AddConstant adds named constant values for use within expressions.
Example: AddConstant('X', 50)
procedure AddFunction0Param(const Name : string; FunctionAddr : TStFunction0Param);
procedure AddFunction1Param(const Name : string; FunctionAddr : TStFunction1Param);
procedure AddFunction2Param(const Name : string; FunctionAddr : TStFunction2Param);
procedure AddFunction3Param(const Name : string; FunctionAddr : TStFunction3Param);
-> AddFunctionXParam adds support for user-defined functions within expressions.
The four variations allow defining functions with no parameters, or, with one,
two, or three parameters. Name is the identifier that is entered into the
expression. The name does not need to be the same as the actual function name.
Parameter and function results must be defined as TStFloat.
procedure AddInternalFunctions;
-> AddInternalFunctions adds support for all of the predefined internal
functions.
Since AddInternalFunctions is called by default, calling this routine without
first calling ClearIdentifiers will result in duplicate identifier exceptions.
procedure AddMethod0Param(const Name : string; MethodAddr : TStMethod0Param);
procedure AddMethod1Param(const Name : string; MethodAddr : TStMethod1Param);
procedure AddMethod2Param(const Name : string; MethodAddr : TStMethod2Param);
procedure AddMethod3Param(const Name : string; MethodAddr : TStMethod3Param);
-> AddMethodXParam adds support for user-defined methods within expressions.
The four variations allow defining methods with no parameters, or, with one,
two, or three parameters. Name is the identifier that is entered into the
expression. The name does not need to be the same as the actual method name.
Parameter and function results must be defined as TStFloat.
procedure AddVariable(const Name : string; VariableAddr : PStFloat);
-> Adds Name as a reference to a variable in your program.
Name is the identifier used in expressions.
Example:
var
X : TStFloat;
...
AddVariable('X', @X)
procedure ClearIdentifiers;
-> ClearIdentifiers removes all function, method, constant, and variable identifiers.
procedure GetIdentList(S : TStrings);
-> GetIdentList fills S with a list of identifiers current recognized.
procedure RemoveIdentifier(const Name : string);
-> RemoveIdentifier removes support for the identifier Name.
If Name is not found, no action is taken.
properties
----------
property AsFloat : TStFloat (run-time read-only)
-> AsFloat evaluates the expression and returns the value as a TStFloat
value;
property AsInteger : Integer (run-time read-only)
-> AsInteger evaluates the expression and returns the value as a whole number
using the Round() function to convert the TStFloat value.
property AsString : string (run-time read-only)
-> AsString evaluates the expression and returns the value as a string using
the FloatToStr() function to format the TStFloat value.
property LastError : Integer (run-time read-only)
-> LastError returns the error code (zero if no error).
property ErrorPosition : Integer (run-time read-only)
-> ErrorPosition returns the position of the error within the expression.
ErrorPosition is valid only if LastError is non-zero.
property Expression : string (run-time)
-> Expression defines the expression that should be evaluated.
property AllowEqual : Boolean
default: True
-> AllowEqual determines if the use of the "=" symbol in the expression will
add constant declarations.
If true, expressions like X = 5 will cause the identifer "X" to be added and
associated with the value 5. This expression will also return a value of 5
when analyzed. If false, a bad character exception is raised.
events
------
property OnAddIdentifier : TNotifyEvent
-> OnAddIdentifier defines an event that is fired when a new identifier
is added.
This event is fired for additions of function, method, constant, and variable
identifiers.
property OnGetIdentValue : TGetIdentValueEvent
TGetIdentValueEvent =
procedure(Sender : TObject; const Identifier : string; var Value : TStFloat)
of object;
-> OnGetIdentValue defines an event handler that is fired to obtain the value
for an identifier that was not found in the internal list of known identifiers.
TStExpressionEdit
=================
The TStExpressionEdit component is a simple descendant of a TEdit component
that adds one new method, two properties, and two new events. In all other
respects, this control is the same as the standard VCL TEdit control.
The TStExpressionEdit uses an instance of the TStExpression component to do
most of the work. Any expression that is valid for the TStExpression
component can be entered into the component or assigned to the Text property.
The expression is evaluated when the component loses the focus (with AutoEval
true) or when the Evaluate method is called. Also, if AutoEval is true and
the control loses the focus, the resulting value is displayed in the control.
New properties and methods:
function Evaluate : TStFloat;
-> Evaluate evaluates the contents of the Text property as an expression
using the contained TStExpression component and returns the result of the
expression as the function result.
If an error occurs an exception is raised unless an event handler for the
OnError event is assigned. In which case, the event is fired instead.
Note: The AnalyzeExpr function (which is documented in the printed
manual and on-line help) is obsolete and is provided for backward
compatibility only.
property AutoEval : Boolean
-> AutoEval determines if the entered expression is automatically evaluated
when the control loses the focus.
If AutoEval is true, the Evaluate method is called automatically and the
Text of the edit control is set to the result of evaluating the expression.
If False, no additional action is taken.
property Expr : TStExpression (run-time)
-> Expr provides access to the contained TStExpression component and all of
its properties, methods, and events.
property OnAddIdentifier : TNotifyEvent
-> OnAddIdentifier defines an event that is fired when an identifier is
added to the internal TStExpression component.
This event is fired to notify you that a constant or function identifier has
been added to the contained TStExpression component.
property OnError : TStExprErrorEvent
TStExprErrorEvent =
procedure(Sender : TObject; ErrorNumber : LongInt; const ErrorStr : string)
of object;
-> OnError defines an event that is fired when an evaluation error occurs.

1312
components/systools/source/run/stfin.pas Normal file
View File

File diff suppressed because it is too large Load Diff

995
components/systools/source/run/sthash.pas Normal file
View File

@ -0,0 +1,995 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StHASH.PAS 4.04 *}
{*********************************************************}
{* SysTools: Hash table class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
{Notes:
- Generally the same as STDICT.PAS, but the hash table is
keyed on elements of arbitrary type rather than just strings.
- Also manages an LRU counter and updates each node's LRU when
it is added or accessed. If the maximum allowed number of nodes
in the table is exceeded, the least recently used node is
automatically removed from the table. By default, MaxLongInt
nodes can be in the table so the automatic removal logic does
not come into play. When a node is automatically removed, the
NodeRemoved virtual method is called to notify the program
that the node is being removed.
}
unit StHASH;
interface
uses
SysUtils,
Classes,
{$IFNDEF FPC}
{$IFDEF ThreadSafe}
Windows,
{$ENDIF}
{$ENDIF}
StConst,
StBase;
type
TStHashNode = class(TStNode)
{.Z+}
protected
hnNext : TStHashNode; {Next node in hash list}
hnValue: Pointer; {Pointer to value of element}
hnValSize : Cardinal; {Size of hnValue memory block}
FLRU : LongInt; {LRU counter of this node}
function GetValue : Pointer;
{.Z-}
public
constructor CreateNode(const AValue; AValSize : Cardinal; AData : Pointer);
virtual;
{-Initialize node}
destructor Destroy; override;
{-Free name string and destroy node}
property Value : Pointer
read GetValue;
property LRU : LongInt
read FLRU
write FLRU;
end;
{.Z+}
THashArray = array[0..(MaxInt div SizeOf(TStHashNode))-1] of TStHashNode;
PHashArray = ^THashArray;
{.Z-}
THashFunc = function (const V; Size : Integer) : Integer;
TStHashTable = class(TStContainer)
{.Z+}
protected
{property instance variables}
FValSize : Cardinal; {Size of each element in table}
FHashSize : Integer; {Bins in hash array}
FEqual : TUntypedCompareFunc; {Element compare function}
FHash : THashFunc; {Hash function}
FMaxNodes : LongInt; {Max nodes allowed in table}
{private instance variables}
htHeads : PHashArray; {Pointer to head of node lists}
htTails : PHashArray; {Pointer to tail of node lists}
htLRU : LongInt; {LRU counter}
htIgnoreDups : Boolean; {Ignore duplicates during Join?}
{protected undocumented methods}
procedure htInsertNode(H : Integer; This : TStHashNode);
procedure htIterate(Action : TIterateFunc; OtherData : Pointer;
var H : Integer; var Prev, This : TStHashNode);
procedure htSetEqual(E : TUntypedCompareFunc);
procedure htSetHash(H : THashFunc);
procedure htSetHashSize(Size : Integer);
procedure htSetMaxNodes(Nodes : LongInt);
procedure htMoveToFront(H : Integer; Prev, This : TStHashNode);
procedure htFindNode(const V; var H : Integer;
var Prev, This : TStHashNode);
procedure htUpdateLRU(This : TStHashNode);
procedure htDeleteOldestNode;
{.Z-}
public
constructor Create(AValSize : Cardinal; AHashSize : Integer); virtual;
{-Initialize an empty hash table}
destructor Destroy; override;
{-Destroy a hash table}
procedure LoadFromStream(S : TStream); override;
{-Read a hash table and its data from a stream}
procedure StoreToStream(S : TStream); override;
{-Write a hash table and its data to a stream}
procedure Clear; override;
{-Remove all nodes from container but leave it instantiated}
function Exists(const V; var Data : Pointer) : Boolean;
{-Return True and the Data pointer if V is in the hash table}
procedure Add(const V; Data : Pointer);
{-Add new value and Data to the hash table}
procedure Delete(const V);
{-Delete a value from the hash table}
procedure Update(const V; Data : Pointer);
{-Update the data for an existing element}
function Find(Data : Pointer; var V) : Boolean;
{-Return True and the element value that matches Data}
procedure Assign(Source: TPersistent); override;
{-Assign another hash table's contents to this one}
procedure Join(H : TStHashTable; IgnoreDups : Boolean);
{-Add hash table H into this one and dispose H}
function Iterate(Action : TIterateFunc;
OtherData : Pointer) : TStHashNode;
{-Call Action for all the nodes, returning the last node visited}
procedure NodeRemoved(const V; Data : Pointer); virtual;
{-Called when a not recently used node is removed from the table}
function BinCount(H : Integer) : LongInt;
{-Return number of names in a hash bin (for testing)}
property Equal : TUntypedCompareFunc
{-Change the string compare function; only for an empty table}
read FEqual
write htSetEqual;
property Hash : THashFunc
{-Change the hash function; only for an empty table}
read FHash
write htSetHash;
property HashSize : Integer
{-Change the hash table size; preserves existing elements}
read FHashSize
write htSetHashSize;
property ValSize : Cardinal
{-Read the size of each element in the table}
read FValSize;
property MaxNodes : LongInt
{-Change the maximum nodes in the table}
read FMaxNodes
write htSetMaxNodes;
end;
{======================================================================}
implementation
{$IFDEF ThreadSafe}
var
ClassCritSect : TRTLCriticalSection;
{$ENDIF}
procedure EnterClassCS;
begin
{$IFDEF ThreadSafe}
EnterCriticalSection(ClassCritSect);
{$ENDIF}
end;
procedure LeaveClassCS;
begin
{$IFDEF ThreadSafe}
LeaveCriticalSection(ClassCritSect);
{$ENDIF}
end;
{----------------------------------------------------------------------}
constructor TStHashNode.CreateNode(const AValue; AValSize : Cardinal;
AData : Pointer);
begin
Create(AData);
hnValSize := AValSize;
GetMem(hnValue, AValSize);
Move(AValue, hnValue^, AValSize);
end;
destructor TStHashNode.Destroy;
begin
if Assigned(hnValue) then
FreeMem(hnValue, hnValSize);
inherited Destroy;
end;
function TStHashNode.GetValue : Pointer;
begin
Result := hnValue;
end;
{----------------------------------------------------------------------}
procedure TStHashTable.Add(const V; Data : Pointer);
var
H : Integer;
P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
htFindNode(V, H, P, T);
if Assigned(T) then
RaiseContainerError(stscDupNode);
htInsertNode(H, TStHashNode.CreateNode(V, FValSize, Data));
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function AssignNode(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
var
HashNode : TStHashNode absolute Node;
OurHashTbl : TStHashTable absolute OtherData;
begin
OurHashTbl.Add(HashNode.Value^, HashNode.Data);
Result := true;
end;
procedure TStHashTable.Assign(Source: TPersistent);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{The only container that we allow to be assigned to a hash table
is... another hash table}
if (Source is TStHashTable) then begin
Clear;
FValSize := TStHashTable(Source).ValSize;
TStHashTable(Source).Iterate(AssignNode, Self);
end
else
inherited Assign(Source);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function TStHashTable.BinCount(H : Integer) : LongInt;
var
C : LongInt;
T : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
C := 0;
T := htHeads^[H];
while Assigned(T) do begin
inc(C);
T := T.hnNext;
end;
Result := C;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.Clear;
var
TableSize : Cardinal;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if FCount <> 0 then begin
Iterate(DestroyNode, nil);
FCount := 0;
htLRU := 0;
TableSize := FHashSize*SizeOf(TStHashNode);
FillChar(htHeads^, TableSize, 0);
FillChar(htTails^, TableSize, 0);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
constructor TStHashTable.Create(AValSize : Cardinal; AHashSize : Integer);
begin
if AValSize = 0 then
RaiseContainerError(stscBadSize);
CreateContainer(TStHashNode, 0);
FValSize := AValSize;
FMaxNodes := MaxLongInt;
{allocate hash table by assigning to the HashSize property}
HashSize := AHashSize;
end;
procedure TStHashTable.Delete(const V);
var
H : Integer;
P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
htFindNode(V, H, P, T);
if Assigned(T) then begin
if Assigned(P) then
P.hnNext := T.hnNext
else
htHeads^[H] := T.hnNext;
if T = htTails^[H] then
htTails^[H] := P;
DestroyNode(Self, T, nil);
Dec(FCount);
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
destructor TStHashTable.Destroy;
var
TableSize : Cardinal;
begin
if conNodeProt = 0 then
Clear;
TableSize := FHashSize*SizeOf(TStHashNode);
if Assigned(htHeads) then
FreeMem(htHeads, TableSize);
if Assigned(htTails) then
FreeMem(htTails, TableSize);
IncNodeProtection;
inherited Destroy;
end;
function TStHashTable.Exists(const V; var Data : Pointer) : Boolean;
var
H : Integer;
P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
htFindNode(V, H, P, T);
if Assigned(T) then begin
htMoveToFront(H, P, T);
htUpdateLRU(T);
Result := True;
Data := T.Data;
end else
Result := False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function FindNodeData(Container : TStContainer; Node : TStNode;
OtherData : Pointer) : Boolean; far;
begin
Result := (OtherData <> Node.Data);
end;
function TStHashTable.Find(Data : Pointer; var V) : Boolean;
var
H : Integer;
P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
htIterate(FindNodeData, Data, H, P, T);
if Assigned(T) then begin
htMoveToFront(H, P, T);
htUpdateLRU(T);
Result := True;
Move(T.Value^, V, FValSize);
end else
Result := False;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.htDeleteOldestNode;
{-Find and delete the hash node with the smallest LRU counter}
var
H, MinH : Integer;
MinLRU : LongInt;
T, P : TStHashNode;
begin
if FCount <> 0 then begin
MinLRU := MaxLongInt;
MinH := 0;
for H := 0 to FHashSize-1 do
if Assigned(htTails^[H]) and (htTails^[H].LRU <= MinLRU) then begin
MinH := H;
MinLRU := htTails^[H].LRU;
end;
{notify the application}
with htTails^[MinH] do
NodeRemoved(hnValue^, Data);
{destroy the node}
DestroyNode(Self, htTails^[MinH], nil);
dec(FCount);
{remove the node}
if htTails^[MinH] = htHeads^[MinH] then begin
{only node in this bin}
htTails^[MinH] := nil;
htHeads^[MinH] := nil;
end else begin
{at least two nodes in this bin}
T := htHeads^[MinH];
P := nil;
while T <> htTails^[MinH] do begin
P := T;
T := T.hnNext;
end;
P.hnNext := nil;
htTails^[MinH] := P;
end;
end;
end;
procedure TStHashTable.htFindNode(const V; var H : Integer;
var Prev, This : TStHashNode);
var
P, T : TStHashNode;
begin
if not(Assigned(FEqual) and Assigned(FHash)) then
RaiseContainerError(stscNoCompare);
Prev := nil;
This := nil;
H := FHash(V, HashSize);
T := htHeads^[H];
P := nil;
while Assigned(T) do begin
if FEqual(V, T.Value^) = 0 then begin
Prev := P;
This := T;
Exit;
end;
P := T;
T := T.hnNext;
end;
{not found}
This := nil;
end;
procedure TStHashTable.htInsertNode(H : Integer; This : TStHashNode);
{-Insert node This at front of hash bin H}
var
P : TStHashNode;
begin
P := htHeads^[H];
htHeads^[H] := This;
if not Assigned(htTails^[H]) then
htTails^[H] := This;
This.hnNext := P;
htUpdateLRU(This);
Inc(FCount);
if FCount > FMaxNodes then
htDeleteOldestNode;
end;
procedure TStHashTable.htIterate(Action : TIterateFunc; OtherData : Pointer;
var H : Integer; var Prev, This : TStHashNode);
{-Internal version of Iterate that returns more details}
var
AHash : Integer;
P, T, N : TStHashNode;
begin
if FCount <> 0 then begin
for AHash := 0 to FHashSize-1 do begin
T := htHeads^[AHash];
P := nil;
while Assigned(T) do begin
N := T.hnNext;
if Action(Self, T, OtherData) then begin
P := T;
T := N;
end else begin
H := AHash;
Prev := P;
This := T;
Exit;
end;
end;
end;
end;
This := nil;
end;
procedure TStHashTable.htMoveToFront(H : Integer; Prev, This : TStHashNode);
{-Move This to front of list}
begin
if Assigned(Prev) then begin
Prev.hnNext := This.hnNext;
This.hnNext := htHeads^[H];
htHeads^[H] := This;
if This = htTails^[H] then
htTails^[H] := Prev;
end;
end;
procedure TStHashTable.htSetEqual(E : TUntypedCompareFunc);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
FEqual := E;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.htSetHash(H : THashFunc);
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
if Count = 0 then
FHash := H;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.htSetHashSize(Size : Integer);
var
HInx : integer;
TableSize: LongInt;
Temp : TStHashNode;
Node : TStHashNode;
OldHeads : PHashArray;
OldTails : PHashArray;
OldSize : Integer;
OldCount : Integer;
OldDisposeData : TDisposeDataProc;
OldOnDisposeData : TStDisposeDataEvent;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
{calculate the new table size}
TableSize := LongInt(Size) * sizeof(TStHashNode);
if (Size <= 0) {or (TableSize > MaxBlockSize)} then
RaiseContainerError(stscBadSize);
{only do something if there's something to do}
if (Size <> FHashSize) then begin
{Notes: lots of things are going to be happening here: new
allocations, nodes copied from the old table to the new,
etc. Ideally if an exception is raised we would like to
restore the hash table to the state it was in
originally, before letting the exception escape}
{save enough data about the current state of the table to
allow restoring in case of an exception}
OldHeads := htHeads;
OldTails := htTails;
OldSize := FHashSize;
OldCount := FCount;
OldDisposeData := DisposeData;
OldOnDisposeData := OnDisposeData;
{reset Self's data}
htHeads := nil;
htTails := nil;
FHashSize := Size;
FCount := 0;
DisposeData := nil;
OnDisposeData := nil;
{from this point, exceptions can occur with impunity...}
try
{allocate the new head and tail tables}
htHeads := AllocMem(TableSize);
htTails := AllocMem(TableSize);
{if there is data to transfer, do so}
if (OldHeads <> nil) and (OldCount <> 0) then begin
for HInx := 0 to pred(OldSize) do begin
Node := OldHeads^[HInx];
while Assigned(Node) do begin
Add(Node.hnValue^, Node.Data);
Node := Node.hnNext;
end;
end;
end;
{now all the data has been transferred, we can
destroy the old table}
if (OldHeads <> nil) then begin
for HInx := 0 to pred(OldSize) do begin
Node := OldHeads^[HInx];
while Assigned(Node) do begin
Temp := Node;
Node := Node.hnNext;
Temp.Free;
end;
end;
FreeMem(OldHeads, OldSize * sizeof(TStHashNode));
end;
if (OldTails <> nil) then
FreeMem(OldTails, OldSize * sizeof(TStHashNode));
{restore the disposedata routines}
DisposeData := OldDisposeData;
OnDisposeData := OldOnDisposeData;
except
{destroy the new data}
if (htHeads <> nil) then begin
for HInx := 0 to pred(FHashSize) do begin
Node := htHeads^[HInx];
while Assigned(Node) do begin
Temp := Node;
Node := Node.hnNext;
Temp.Free;
end;
end;
FreeMem(htHeads, TableSize);
end;
if (htTails <> nil) then
FreeMem(htTails, TableSize);
{restore the old data}
htHeads := OldHeads;
htTails := OldTails;
FHashSize := OldSize;
FCount := OldCount;
DisposeData := OldDisposeData;
OnDisposeData := OldOnDisposeData;
{reraise the exception}
raise;
end;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.htSetMaxNodes(Nodes : LongInt);
begin
if Nodes < 1 then
RaiseContainerError(stscBadSize);
FMaxNodes := Nodes;
while FCount > FMaxNodes do
htDeleteOldestNode;
end;
type
TMinNode = record
MLRU : LongInt;
MNode : TStHashNode;
end;
PMinNode = ^TMinNode;
function FindMinPositiveNode(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
{-Used to find the smallest non-negative LRU in the table}
begin
with PMinNode(OtherData)^, TStHashNode(Node) do
if (LRU >= 0) and (LRU <= MLRU) then begin
MLRU := LRU;
MNode := TStHashNode(Node);
end;
Result := True;
end;
function NegateNodeLRU(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
{-Used to negate the LRU values of all nodes in the table}
begin
with TStHashNode(Node) do
LRU := -LRU;
Result := True;
end;
procedure TStHashTable.htUpdateLRU(This : TStHashNode);
{-Reassign all LRU values sequentially in their existing order}
var
MinNode : TMinNode;
begin
inc(htLRU);
This.LRU := htLRU;
if htLRU = MaxLongInt then begin
{scan table and pack LRU values}
htLRU := 0;
repeat
inc(htLRU);
MinNode.MLRU := MaxLongInt;
MinNode.MNode := nil;
Iterate(FindMinPositiveNode, @MinNode);
if not Assigned(MinNode.MNode) then
break;
{nodes already visited are set to a negative value}
{depends on never having an LRU of zero}
MinNode.MNode.LRU := -htLRU;
until False;
{negative values are made positive}
Iterate(NegateNodeLRU, nil);
end;
end;
function TStHashTable.Iterate(Action : TIterateFunc;
OtherData : Pointer) : TStHashNode;
var
H : Integer;
P : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
htIterate(Action, OtherData, H, P, Result);
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
function JoinNode(Container : TStContainer;
Node : TStNode;
OtherData : Pointer) : Boolean; far;
{-Used to add nodes from another table into this one}
var
H : Integer;
P, T : TStHashNode;
begin
Result := True;
with TStHashTable(OtherData) do begin
htFindNode(TStHashNode(Node).Value^, H, P, T);
if Assigned(T) then
if htIgnoreDups then begin
Node.Free;
Exit;
end else
RaiseContainerError(stscDupNode);
htInsertNode(H, TStHashNode(Node));
end;
end;
procedure TStHashTable.Join(H : TStHashTable; IgnoreDups : Boolean);
begin
{$IFDEF ThreadSafe}
EnterClassCS;
EnterCS;
H.EnterCS;
try
{$ENDIF}
htIgnoreDups := IgnoreDups;
H.Iterate(JoinNode, Self);
{dispose of D, but not its nodes}
H.IncNodeProtection;
H.Free;
{$IFDEF ThreadSafe}
finally
H.LeaveCS;
LeaveCS;
LeaveClassCS;
end;
{$ENDIF}
end;
procedure TStHashTable.LoadFromStream(S : TStream);
var
Data, Value : Pointer;
AValSize : Cardinal;
Reader : TReader;
StreamedClass : TPersistentClass;
StreamedNodeClass : TPersistentClass;
StreamedClassName : string;
StreamedNodeClassName : string;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Clear;
Reader := TReader.Create(S, 1024);
try
with Reader do begin
StreamedClassName := ReadString;
StreamedClass := GetClass(StreamedClassName);
if not Assigned(StreamedClass) then
RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
if (StreamedClass <> Self.ClassType) then
RaiseContainerError(stscWrongClass);
StreamedNodeClassName := ReadString;
StreamedNodeClass := GetClass(StreamedNodeClassName);
if not Assigned(StreamedNodeClass) then
RaiseContainerErrorFmt(stscUnknownNodeClass, [StreamedNodeClassName]);
if (StreamedNodeClass <> conNodeClass) then
RaiseContainerError(stscWrongNodeClass);
AValSize := ReadInteger;
if AValSize <> FValSize then
RaiseContainerError(stscBadSize);
HashSize := ReadInteger;
FMaxNodes := ReadInteger;
GetMem(Value, FValSize);
try
ReadListBegin;
while not EndOfList do begin
ReadBoolean;
Read(Value^, FValSize);
Data := DoLoadData(Reader);
Add(Value^, Data);
end;
ReadListEnd;
finally
FreeMem(Value, FValSize);
end;
end;
finally
Reader.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.NodeRemoved(const V; Data : Pointer);
begin
{does nothing by default}
end;
procedure TStHashTable.StoreToStream(S : TStream);
var
H : Integer;
Walker : TStHashNode;
Writer : TWriter;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
Writer := TWriter.Create(S, 1024);
try
with Writer do begin
WriteString(Self.ClassName);
WriteString(conNodeClass.ClassName);
WriteInteger(FValSize);
WriteInteger(FHashSize);
WriteInteger(FMaxNodes);
WriteListBegin;
if Count <> 0 then
for H := 0 to FHashSize-1 do begin
Walker := htHeads^[H];
while Assigned(Walker) do begin
{writing the True boolean prevents false termination of the
list if Value's first byte is zero when the stream is
loaded into another hash table}
WriteBoolean(True);
Write(Walker.Value^, FValSize);
DoStoreData(Writer, Walker.Data);
Walker := Walker.hnNext;
end;
end;
WriteListEnd;
end;
finally
Writer.Free;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
procedure TStHashTable.Update(const V; Data : Pointer);
var
H : Integer;
P, T : TStHashNode;
begin
{$IFDEF ThreadSafe}
EnterCS;
try
{$ENDIF}
htFindNode(V, H, P, T);
if Assigned(T) then begin
htMoveToFront(H, P, T);
htUpdateLRU(T);
T.Data := Data;
end;
{$IFDEF ThreadSafe}
finally
LeaveCS;
end;
{$ENDIF}
end;
{$IFDEF ThreadSafe}
initialization
Windows.InitializeCriticalSection(ClassCritSect);
finalization
Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.

594
components/systools/source/run/stinistm.pas Normal file
View File

@ -0,0 +1,594 @@
// Upgraded to Delphi 2009: Sebastian Zierer
// FIXME: TStAnsiTextStream
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StIniStm.pas 4.04 *}
{*********************************************************}
{* SysTools: .INI file-like stream class *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$include StDefine.inc}
unit StIniStm;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes, StStrms;
type
TStIniStream = class(TObject)
private
FAnsiStream : TStAnsiTextStream;
FSections : TStringList;
procedure GetSecStrings(Strs: TStrings);
protected
procedure GotoSection(const Section : String);
procedure UpdateSections;
procedure WriteSectionName(const Section : String);
procedure WriteValue(const Key, Value : String);
public
constructor Create(aStream : TStream);
destructor Destroy; override;
function SectionExists(const Section : String): Boolean;
function ReadString(const Section, Ident, Default : String) : String;
procedure WriteString(const Section, Ident, Value : String);
procedure WriteSection(const Section : String; Strings: TStrings);
procedure ReadSection(const Section : String; Strings: TStrings);
procedure ReadSections(Strings: TStrings);
procedure ReadSectionValues(const Section : String; Strings: TStrings);
procedure EraseSection(const Section : String);
procedure DeleteKey(const Section, Ident : String);
function ValueExists(const Section, Ident : String): Boolean;
end;
procedure SplitNameValue(const Line : string; var Name, Value : string); {!!.04}
implementation
{!!.04 - Added }
procedure SplitNameValue(const Line : string; var Name, Value : string);
var
P : Integer;
begin
P := Pos('=', Line);
if P < 1 then begin
Name := Line;
Value := '';
Exit;
end;
Name := Copy(Line, 1, P-1);
Value := Copy(Line, P+1, Length(Line) - P);
end;
{!!.04 - Added End}
function IsHeader(const AString : String) : Boolean;
{ see if passed in text looks like an .INI header }
var
Temp : String;
begin
if AString = '' then begin
Result := False;
Exit;
end;
Temp := Trim(AString);
Result := (Temp[1] = '[') and (Temp[Length(Temp)] = ']')
end;
{ TStIniStream }
constructor TStIniStream.Create(aStream: TStream);
begin
inherited Create;
FAnsiStream := TStAnsiTextStream.Create(aStream);
FSections := TStringList.Create;
FSections.Sorted := True;
FSections.Duplicates := dupIgnore;
if aStream.Size > 0 then { not an empty stream }
UpdateSections;
end;
destructor TStIniStream.Destroy;
begin
FSections.Free;
FAnsiStream.Free;
inherited Destroy;
end;
procedure TStIniStream.DeleteKey(const Section, Ident : String);
{ delete specified item from Section }
var
SecStrs : TStringList;
SecIdx : Integer;
MS : TMemoryStream;
TS : TStAnsiTextStream;
i, Idx : Integer;
begin
SecStrs := TStringList.Create;
MS := TMemoryStream.Create;
TS := TStAnsiTextStream.Create(MS);
try
{ locate and read section }
GotoSection(Section);
GetSecStrings(SecStrs);
Idx := SecStrs.IndexOfName(Ident);
if Idx > - 1 then begin
{ remove desired key }
SecStrs.Delete(Idx);
{ locate subsequent section }
SecIdx := FSections.IndexOf(Section);
if SecIdx < Pred(FSections.Count) then begin
GotoSection(FSections[SecIdx+1]);
{ copy remaining sections }
while not FAnsiStream.AtEndOfStream do
TS.WriteLine(FAnsiStream.ReadLine);
end;
{ else this is the last section }
{ seek back and truncate }
GotoSection(Section);
FAnsiStream.Size := FAnsiStream.Position;
// FAnsiStream.SetSize(FAnsiStream.Position);
{ write updated section }
WriteSectionName(Section);
for i := 0 to Pred(SecStrs.Count) do
FAnsiStream.WriteLine(SecStrs[i]);
FAnsiStream.Stream.Seek(0, soFromEnd);
{ append saved subsequent sections }
TS.SeekLine(0);
while not TS.AtEndOfStream do
FAnsiStream.WriteLine(TS.ReadLine);
end; { if Ident > -1 }
{ else the Ident doesn't exist so don't alter anything }
finally
SecStrs.Free;
TS.Free;
MS.Free;
end;
end;
procedure TStIniStream.EraseSection(const Section : String);
{ erase specified section from Ini data }
var
SecIdx : Integer;
MS : TMemoryStream;
TS : TStAnsiTextStream;
begin
MS := TMemoryStream.Create;
TS := TStAnsiTextStream.Create(MS);
{ locate section }
SecIdx := FSections.IndexOf(Section);
{ if section found }
if SectionExists(Section) then begin
try
{ if this is not the last section }
if (SecIdx < Pred(FSections.Count)) then begin
{ locate subsequent section }
GotoSection(FSections[SecIdx+1]);
{ copy remaining sections to temporary stream}
while not FAnsiStream.AtEndOfStream do
TS.WriteLine(FAnsiStream.ReadLine);
end;
{ else this is the last section }
{ locate section to delete and truncate }
GotoSection(Section);
FAnsiStream.Size := FAnsiStream.Position;
// FAnsiStream.SetSize(FAnsiStream.Position);
{ append saved subsequent sections }
TS.SeekLine(0);
while not TS.AtEndOfStream do
FAnsiStream.WriteLine(TS.ReadLine);
finally
TS.Free;
MS.Free;
end;
UpdateSections;
end;
{ else section doesn't exist, do nothing }
end;
procedure TStIniStream.GetSecStrings(Strs : TStrings);
{ read strings from a section, preserving comments and blanks }
var
LineVal : String;
begin
{ assume we're at the start of a section }
FAnsiStream.ReadLine; { skip section header }
LineVal := FAnsiStream.ReadLine;
while not (FAnsiStream.AtEndOfStream) and not (IsHeader(LineVal)) do begin
Strs.Add(LineVal); { add it to the list }
LineVal := FAnsiStream.ReadLine; { get next line }
end;
end;
procedure TStIniStream.GotoSection(const Section: String);
{ position stream to requested section header }
var
Idx : Integer;
begin
Idx := FSections.IndexOf(Section);
if Idx > -1 then
FAnsiStream.SeekLine(Integer(FSections.Objects[Idx]));
end;
procedure TStIniStream.ReadSectionValues(const Section : String;
Strings: TStrings);
{ return <Name>=<Value> pairs of requested Section in Strings }
var
Strs : TStringList;
LineVal : String;
i : Integer;
begin
if not Assigned(Strings) then Exit;
Strs := TStringList.Create;
if SectionExists(Section) then begin { section exists }
Strings.Clear;
try
{ locate section }
GotoSection(Section);
{ retrieve section contents, comments, blank lines and all }
GetSecStrings(Strs);
{ iterate section lines looking for entries }
for i := 0 to Pred(Strs.Count) do begin
LineVal := Strs[i];
if (Trim(LineVal) <> '') and (Trim(LineVal[1]) <> ';') and (Pos('=', LineVal) > 0) then {!!.02}
{ not empty and not a comment and at least superficially resembles a
<Name>=<Value> pair }
Strings.Add(Trim(LineVal)); { add it to the list } {!!.02}
end;
finally
Strs.Free;
end;
end;
{ else section doesn't exist, do nothing }
end;
procedure TStIniStream.ReadSections(Strings: TStrings);
var
i : Integer;
begin
if not Assigned(Strings) then Exit;
{ omit the pseudo section }
for i := 1 to Pred(FSections.Count) do
Strings.Add(Trim(FSections[i])); {!!.02}
end;
procedure TStIniStream.ReadSection(const Section : String;
Strings: TStrings);
{ return Name strings for all entries in requested section }
var
SecStrs : TStringList;
i : Integer;
LineVal, Name : String;
begin
if not Assigned(Strings) then Exit;
SecStrs := TStringList.Create;
try
// ReadSection(Section, SecStrs);
{!!.02 - Rewritten }
Strings.Clear;
{ locate section }
GotoSection(Section);
{ retrieve section contents, comments, blank lines and all }
GetSecStrings(SecStrs);
{ iterate section lines looking for entries }
for i := 0 to Pred(SecStrs.Count) do begin
LineVal := SecStrs[i];
if (Trim(LineVal) <> '') and (Trim(LineVal[1]) <> ';') and (Pos('=', LineVal) > 0) then begin
{ not empty and not a comment and at least superficially resembles a
<Name>=<Value> pair }
SplitNameValue(LineVal, Name, LineVal);
Strings.Add(Trim(Name));
end;
end;
// for i := 0 to Pred(SecStrs.Count) do
// Strings.Add(SecStrs.Names[i]);
{!!.02 - Rewritten End }
finally
SecStrs.Free;
end;
end;
function TStIniStream.ReadString(const Section, Ident,
Default : String) : String;
{
return a particular string selected by Ident from Section
if empty or doesn't exist, return Default
}
var
SecStrs : TStringList;
begin
SecStrs := TStringList.Create;
try
ReadSectionValues(Section, SecStrs); {!!.04}
Result := SecStrs.Values[Ident];
if Result = '' then
Result := Default;
finally
SecStrs.Free;
end;
end;
function TStIniStream.SectionExists(const Section : String): Boolean;
{ returns True if Section exists in section list, False otherwise }
begin
Result := FSections.IndexOf(Section) > -1;
end;
procedure TStIniStream.UpdateSections;
{ refresh Sections list }
var
i : Integer;
Line : String;
begin
i := 0;
FSections.Clear;
FAnsiStream.SeekLine(0);
{ pseudo section to account for any comments or whitespace prior to first
real section in data }
FSections.AddObject('[]', TObject(0));
{ iterate data looking for section headers: '[blah]' }
while not FAnsiStream.AtEndOfStream do begin
Line := Trim(FAnsiStream.ReadLine);
{ if it looks like a header }
if IsHeader(Line) then
{ add it to the list with a line index }
FSections.AddObject(Copy(Line, 2, Length(Line) - 2), TObject(i));
{ go to next line }
Inc(i);
end;
end;
function TStIniStream.ValueExists(const Section, Ident : String): Boolean;
{
see if requested section contains requested Ident
implies "<Ident>=" exists in section, not that there's necessarily any
explicit Value associated, i.e. Value may be blank
}
var
SecStrs : TStringList;
i : Integer;
begin
Result := False;
SecStrs := TStringList.Create;
try
{ get section }
ReadSection(Section, SecStrs);
{ see if Ident exists in Names collection }
for i := 0 to Pred(SecStrs.Count) do
if SecStrs.Names[i] = Ident then begin
Result := True;
Break;
end;
finally
SecStrs.Free;
end;
end;
procedure TStIniStream.WriteString(const Section, Ident, Value : String);
{ write individual string value to IniStream }
var
SecStrs : TStringList;
SecIdx : Integer;
MS : TMemoryStream;
TS : TStAnsiTextStream;
i : Integer;
begin
if SectionExists(Section) then begin
SecStrs := TStringList.Create;
MS := TMemoryStream.Create;
TS := TStAnsiTextStream.Create(MS);
try
{ locate and read section }
GotoSection(Section);
GetSecStrings(SecStrs);
{ locate subsequent section }
SecIdx := FSections.IndexOf(Section);
if SecIdx < Pred(FSections.Count) then begin
GotoSection(FSections[SecIdx+1]);
{ copy remaining sections }
while not FAnsiStream.AtEndOfStream do
TS.WriteLine(FAnsiStream.ReadLine);
end;
{ else this is the last section }
{ seek back and truncate }
GotoSection(Section);
FAnsiStream.Size := FAnsiStream.Position;
// FAnsiStream.SetSize(FAnsiStream.Position);
{ insert new value }
SecStrs.Add(Ident + '=' + Value);
{ write updated section }
WriteSectionName(Section);
for i := 0 to Pred(SecStrs.Count) do
FAnsiStream.WriteLine(SecStrs[i]);
FAnsiStream.Stream.Seek(0, soFromEnd);
{ append saved subsequent sections }
TS.SeekLine(0);
while not TS.AtEndOfStream do
FAnsiStream.WriteLine(TS.ReadLine);
finally
SecStrs.Free;
TS.Free;
MS.Free;
end;
end
else begin { no such section exists, append new one }
FAnsiStream.Seek(0, soFromEnd);
WriteSectionName(Section);
WriteValue(Ident, Value);
UpdateSections;
end;
end;
procedure TStIniStream.WriteSectionName(const Section: String);
{ write section header at current location }
begin
FAnsiStream.WriteLine('[' + Section + ']');
end;
procedure TStIniStream.WriteValue(const Key, Value: String);
{ write <Name>=<Value> pair at current location }
begin
FAnsiStream.WriteLine(Key + '=' + Value);
end;
procedure TStIniStream.WriteSection(const Section: String;
Strings: TStrings);
{ write entire section described by Strings }
var
SecStrs : TStringList;
SecIdx : Integer;
MS : TMemoryStream;
TS : TStAnsiTextStream;
i : Integer;
L : LongInt;
Name : String;
begin
if not Assigned(Strings) then Exit;
if SectionExists(Section) then begin
SecStrs := TStringList.Create;
MS := TMemoryStream.Create;
TS := TStAnsiTextStream.Create(MS);
try
{ locate and read section }
GotoSection(Section);
GetSecStrings(SecStrs);
{ locate subsequent section }
SecIdx := FSections.IndexOf(Section);
if SecIdx < Pred(FSections.Count) then begin
GotoSection(FSections[SecIdx+1]);
{ copy remaining sections }
while not FAnsiStream.AtEndOfStream do
TS.WriteLine(FAnsiStream.ReadLine);
end;
{ else this is the last section }
{ seek back and truncate }
GotoSection(Section);
FAnsiStream.Size := FAnsiStream.Position;
// FAnsiStream.SetSize(FAnsiStream.Position);
{ update section }
for i := 0 to Pred(Strings.Count) do begin
Name := Strings.Names[i];
if SecStrs.IndexOfName(Name) > -1 then { entry exists, change value }
SecStrs.Values[Name] := Strings.Values[Name]
else { new entry, just append it }
SecStrs.Add(Strings[i]);
end;
{ write updated section }
WriteSectionName(Section);
for i := 0 to Pred(SecStrs.Count) do
FAnsiStream.WriteLine(SecStrs[i]);
FAnsiStream.Stream.Seek(0, soFromEnd);
{ append saved subsequent sections }
TS.SeekLine(0);
while not TS.AtEndOfStream do
FAnsiStream.WriteLine(TS.ReadLine);
finally
SecStrs.Free;
TS.Free;
MS.Free;
end;
end
else begin { no such section exists, append new one }
L := FAnsiStream.LineCount;
FAnsiStream.Seek(0, soFromEnd);
WriteSectionName(Section);
FSections.AddObject(Section, TObject(L+1));
for i := 0 to Pred(Strings.Count) do
FAnsiStream.WriteLine(Strings[i]);
// UpdateSections;
end;
end;
end.

175
components/systools/source/run/stmath.pas Normal file
View File

@ -0,0 +1,175 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StMath.pas 4.04 *}
{*********************************************************}
{* SysTools: Miscellaneous math functions *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StMath;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, StDate, StBase, StConst;
const
RadCor : Double = 57.29577951308232; {number of degrees in a radian}
{$IFNDEF UseMathUnit}
function IntPower(Base : Extended; Exponent : Integer): Extended;
{-Raise Base to an integral power Exponent}
function Power(Base, Exponent : Extended) : Extended;
{-Raise Base to an arbitrary power Exponent}
{$ENDIF}
function StInvCos(X : Double): Double;
{-Returns the ArcCos of Y}
function StInvSin(Y : Double): Double;
{-Returns the ArcSin of Y}
function StInvTan2(X, Y : Double) : Double;
{-Returns the ArcTangent of Y / X}
function StTan(A : Double) : Double;
{-Returns the Tangent of A}
{-------------------------------------------------------}
implementation
{$IFNDEF UseMathUnit}
function IntPower(Base : Extended; Exponent : Integer): Extended;
var
Y : Integer;
begin
Y := Abs(Exponent);
Result := 1;
while (Y > 0) do begin
while (not Odd(Y)) do begin
Y := Y shr 1;
Base := Base * Base;
end;
Dec(Y);
Result := Result * Base;
end;
if (Exponent < 0) then
Result := 1 / Result;
end;
{-------------------------------------------------------}
function Power(Base, Exponent: Extended): Extended;
begin
if (Exponent = 0) then
Result := 1
else if (Base = 0) and (Exponent > 0) then
Result := 0
else if (Frac(Exponent) = 0) and (Abs(Exponent) <= MaxInt) then
Result := IntPower(Base, Trunc(Exponent))
else
Result := Exp(Exponent * Ln(Base));
end;
{$ENDIF}
{-------------------------------------------------------}
function StTan(A : Double) : Double;
var
C, S : Double;
begin
C := Cos(A);
S := Sin(A);
if (Abs(C) >= 5E-12) then
Result := S / C
else if (C < 0) then
Result := 5.0e-324
else
Result := 1.7e+308;
end;
{-------------------------------------------------------}
function StInvTan2(X, Y : Double) : Double;
begin
if (Abs(X) < 5.0E-12) then begin
if (X < 0) then
Result := 3 * Pi / 2
else
Result := Pi / 2;
end else begin
Result := ArcTan(Y / X);
if (X < 0) then
Result := Result + Pi
else if (Y < 0) then
Result := Result + 2 * Pi;
end;
end;
{-------------------------------------------------------}
function StInvSin(Y : Double): Double;
begin
if (Abs(Abs(Y) - 1) > 5.0E-12) then
Result := ArcTan(Y / Sqrt(1 - Y * Y))
else begin
if (Y < 0) then
Result := 3 * Pi / 2
else
Result := Pi / 2;
end;
end;
{-------------------------------------------------------}
function StInvCos(X : Double): Double;
begin
if (Abs(Abs(X) - 1) > 5.0E-12) then
Result := (90 / RadCor) - ArcTan(X / Sqrt(1 - X * X))
else begin
if ((X - Pi / 2) > 0) then
Result := 0
else
Result := Pi;
end;
end;
end.

1530
components/systools/source/run/stmoney.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3557
components/systools/source/run/ststrl.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1424
components/systools/source/run/ststrms.pas Normal file
View File

File diff suppressed because it is too large Load Diff

3408
components/systools/source/run/ststrs.pas Normal file
View File

File diff suppressed because it is too large Load Diff

963
components/systools/source/run/sttohtml.pas Normal file
View File

@ -0,0 +1,963 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StToHTML.pas 4.04 *}
{*********************************************************}
{* SysTools: HTML Text Formatter *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
//{$I StDefine.inc}
unit StToHTML;
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StStrms, StBase;
type
TStOnProgressEvent = procedure(Sender : TObject; Percent : Word) of object;
TStStreamToHTML = class(TObject)
protected {private}
{ Private declarations }
FCaseSensitive : Boolean;
FCommentMarkers : TStringList;
FEmbeddedHTML : TStringList;
FInFileSize : Cardinal;
FInFixedLineLen : integer;
FInLineTermChar : Char;
FInLineTerminator: TStLineTerminator;
FInputStream : TStream;
FInSize : Cardinal;
FInTextStream : TStAnsiTextStream;
FIsCaseSensitive : Boolean;
FKeywords : TStringList;
FOnProgress : TStOnProgressEvent;
FOutputStream : TStream;
FOutTextStream : TStAnsiTextStream;
FPageFooter : TStringList;
FPageHeader : TStringList;
FStringMarkers : TStringList;
FWordDelims : String;
protected
{ Protected declarations }
{internal methods}
function ParseBuffer : Boolean;
procedure SetCommentMarkers(Value : TStringList);
procedure SetEmbeddedHTML(Value : TStringList);
procedure SetKeywords(Value : TStringList);
procedure SetPageFooter(Value : TStringList);
procedure SetPageHeader(Value : TStringList);
procedure SetStringMarkers(Value : TStringList);
public
{ Public declarations }
property CaseSensitive : Boolean
read FCaseSensitive
write FCaseSensitive;
property CommentMarkers : TStringList
read FCommentMarkers
write SetCommentMarkers;
property EmbeddedHTML : TStringList
read FEmbeddedHTML
write SetEmbeddedHTML;
property InFixedLineLength : integer
read FInFixedLineLen
write FInFixedLineLen;
property InLineTermChar : Char
read FInLineTermChar
write FInLineTermChar;
property InLineTerminator : TStLineTerminator
read FInLineTerminator
write FInLineTerminator;
property InputStream : TStream
read FInputStream
write FInputStream;
property Keywords : TStringList
read FKeywords
write SetKeywords;
property OnProgress : TStOnProgressEvent
read FOnProgress
write FOnProgress;
property OutputStream : TStream
read FOutputStream
write FOutputStream;
property PageFooter : TStringList
read FPageFooter
write SetPageFooter;
property PageHeader : TStringList
read FPageHeader
write SetPageHeader;
property StringMarkers : TStringList
read FStringMarkers
write SetStringMarkers;
property WordDelimiters : String
read FWordDelims
write FWordDelims;
constructor Create;
destructor Destroy; override;
procedure GenerateHTML;
end;
TStFileToHTML = class(TStComponent)
protected {private}
{ Private declarations }
FCaseSensitive : Boolean;
FCommentMarkers : TStringList;
FEmbeddedHTML : TStringList;
FInFile : TFileStream;
FInFileName : String;
FInLineLength : integer;
FInLineTermChar : Char;
FInLineTerminator : TStLineTerminator;
FKeywords : TStringList;
FOnProgress : TStOnProgressEvent;
FOutFile : TFileStream;
FOutFileName : String;
FPageFooter : TStringList;
FPageHeader : TStringList;
FStream : TStStreamToHTML;
FStringMarkers : TStringList;
FWordDelims : String;
protected
procedure SetCommentMarkers(Value : TStringList);
procedure SetEmbeddedHTML(Value : TStringList);
procedure SetKeywords(Value : TStringList);
procedure SetPageFooter(Value : TStringList);
procedure SetPageHeader(Value : TStringList);
procedure SetStringMarkers(Value : TStringList);
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure Execute;
published
property CaseSensitive : Boolean
read FCaseSensitive
write FCaseSensitive default False;
property CommentMarkers : TStringList
read FCommentMarkers
write SetCommentMarkers;
property EmbeddedHTML : TStringList
read FEmbeddedHTML
write SetEmbeddedHTML;
property InFileName : String
read FInFileName
write FInFileName;
property InFixedLineLength : integer
read FInLineLength
write FInLineLength default 80;
property InLineTermChar : Char
read FInLineTermChar
write FInLineTermChar default #10;
property InLineTerminator : TStLineTerminator
read FInLineTerminator
write FInLineTerminator default ltCRLF;
property Keywords : TStringList
read FKeywords
write SetKeywords;
property OnProgress : TStOnProgressEvent
read FOnProgress
write FOnProgress;
property OutFileName : String
read FOutFileName
write FOutFileName;
property PageFooter : TStringList
read FPageFooter
write SetPageFooter;
property PageHeader : TStringList
read FPageHeader
write SetPageHeader;
property StringMarkers : TStringList
read FStringMarkers
write SetStringMarkers;
property WordDelimiters : String
read FWordDelims
write FWordDelims;
end;
implementation
uses
StConst,
StDict;
(*****************************************************************************)
(* TStStreamToHTML Implementation *)
(*****************************************************************************)
constructor TStStreamToHTML.Create;
begin
inherited Create;
FCommentMarkers := TStringList.Create;
FEmbeddedHTML := TStringList.Create;
FKeywords := TStringList.Create;
FPageFooter := TStringList.Create;
FPageHeader := TStringList.Create;
FStringMarkers := TStringList.Create;
FInputStream := nil;
FOutputStream := nil;
FInFileSize := 0;
FWordDelims := ',; .()';
FInLineTerminator := ltCRLF; {normal Windows text file terminator}
FInLineTermChar := #10;
FInFixedLineLen := 80;
with FEmbeddedHTML do begin
Add('"=&quot;');
Add('&=&amp;');
Add('<=&lt;');
Add('>=&gt;');
Add('�=&iexcl;');
Add('�=&cent;');
Add('�=&pound;');
Add('�=&copy;');
Add('�=&reg;');
Add('�=&plusmn;');
Add('�=&frac14;');
Add('�=&frac12;');
Add('�=&frac34;');
Add('�=&divide;');
end;
end;
destructor TStStreamToHTML.Destroy;
begin
FCommentMarkers.Free;
FCommentMarkers := nil;
FEmbeddedHTML.Free;
FEmbeddedHTML := nil;
FKeywords.Free;
FKeywords := nil;
FPageFooter.Free;
FPageFooter := nil;
FPageHeader.Free;
FPageHeader := nil;
FStringMarkers.Free;
FStringMarkers := nil;
FInTextStream.Free;
FInTextStream := nil;
FOutTextStream.Free;
FOutTextStream := nil;
inherited Destroy;
end;
procedure TStStreamToHTML.GenerateHTML;
begin
if not ((Assigned(FInputStream) and (Assigned(FOutputStream)))) then
RaiseStError(EStToHTMLError, stscBadStream)
else
ParseBuffer;
end;
procedure DisposeString(Data : Pointer); far;
begin
Dispose(PString(Data));
end;
function TStStreamToHTML.ParseBuffer : Boolean;
var
I, J,
P1,
P2,
BRead,
PC : Longint;
CloseStr,
SStr,
EStr,
S,
VS,
AStr,
TmpStr : String;
P : Pointer;
PS : PString;
CommentDict : TStDictionary;
HTMLDict : TStDictionary;
KeywordsDict : TStDictionary;
StringDict : TStDictionary;
CommentPend : Boolean;
function ConvertEmbeddedHTML(const Str2 : String) : String;
var
L,
J : Longint;
PH : Pointer;
begin
Result := '';
{avoid memory reallocations}
SetLength(Result, 1024);
J := 1;
for L := 1 to Length(Str2) do begin
if (not HTMLDict.Exists(Str2[L], PH)) then begin
Result[J] := Str2[L];
Inc(J);
end else begin
Move(String(PH^)[1], Result[J], Length(String(PH^)) * SizeOf(Char));
Inc(J, Length(String(PH^)));
end;
end;
Dec(J);
SetLength(Result, J);
end;
procedure CheckSubString(const Str1 : String);
var
S2 : String;
begin
if (KeywordsDict.Exists(Str1, P)) then begin
VS := String(P^);
S2 := Copy(VS, 1, pos(';', VS)-1)
+ ConvertEmbeddedHTML(Str1)
+ Copy(VS, pos(';', VS)+1, Length(VS));
if (P1 >= Length(Str1)) and (P1 <= Length(TmpStr)) then
S2 := S2 + ConvertEmbeddedHTML(TmpStr[P1]);
end else begin
S2 := ConvertEmbeddedHTML(Str1);
if (P1 >= Length(Str1)) and (P1 <= Length(TmpStr)) then
S2 := S2 + ConvertEmbeddedHTML(TmpStr[P1]);
end;
S := S + S2;
end;
begin
if (Length(FWordDelims) = 0) then
RaiseStError(EStToHTMLError, stscWordDelimiters);
{create Dictionaries for lookups}
CommentDict := TStDictionary.Create(FCommentMarkers.Count+1);
KeywordsDict := TStDictionary.Create(FKeywords.Count+1);
HTMLDict := TStDictionary.Create(FEmbeddedHTML.Count+1);
StringDict := TStDictionary.Create(FStringMarkers.Count+1);
CommentDict.DisposeData := DisposeString;
KeywordsDict.DisposeData := DisposeString;
HTMLDict.DisposeData := DisposeString;
StringDict.DisposeData := DisposeString;
FInTextStream := TStAnsiTextStream.Create(FInputStream);
FInTextStream.LineTermChar := AnsiChar(FInLineTermChar);
FInTextStream.LineTerminator := FInLineTerminator;
FInTextStream.FixedLineLength := FInFixedLineLen;
FInFileSize := FInTextStream.Size;
FOutTextStream := TStAnsiTextStream.Create(FOutputStream);
FOutTextStream.LineTermChar := #10;
FOutTextStream.LineTerminator := ltCRLF;
FOutTextStream.FixedLineLength := 80;
FInLineTerminator := ltCRLF; {normal Windows text file terminator}
FInLineTermChar := #10;
FInFixedLineLen := 80;
try
if (FCaseSensitive) then begin
CommentDict.Hash := AnsiHashStr;
CommentDict.Equal := AnsiCompareStr;
HTMLDict.Hash := AnsiHashStr;
HTMLDict.Equal := AnsiCompareStr;
KeywordsDict.Hash := AnsiHashStr;
KeywordsDict.Equal:= AnsiCompareStr;
StringDict.Hash := AnsiHashStr;
StringDict.Equal := AnsiCompareStr;
end else begin
CommentDict.Hash := AnsiHashText;
CommentDict.Equal := AnsiCompareText;
HTMLDict.Hash := AnsiHashText;
HTMLDict.Equal := AnsiCompareText;
KeywordsDict.Hash := AnsiHashText;
KeywordsDict.Equal:= AnsiCompareText;
StringDict.Hash := AnsiHashText;
StringDict.Equal := AnsiCompareText;
end;
{Add items from string lists to dictionaries}
for I := 0 to pred(FKeywords.Count) do begin
if (Length(FKeywords[I]) = 0) then
continue;
if (pos('=', FKeywords[I]) > 0) then begin
New(PS);
S := FKeywords.Names[I];
PS^ := FKeywords.Values[S];
if (not KeywordsDict.Exists(S, P)) then
KeywordsDict.Add(S, PS)
else
Dispose(PS);
end else
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
end;
for I := 0 to pred(FStringMarkers.Count) do begin
if (Length(FStringMarkers[I]) = 0) then
continue;
if (pos('=', FStringMarkers[I]) > 0) then begin
New(PS);
S := FStringMarkers.Names[I];
PS^ := FStringMarkers.Values[S];
if (not StringDict.Exists(S, P)) then
StringDict.Add(S, PS)
else
Dispose(PS);
end else
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
end;
for I := 0 to pred(FCommentMarkers.Count) do begin
if (Length(FCommentMarkers[I]) = 0) then
continue;
if (pos('=', FCommentMarkers[I]) > 0) then begin
New(PS);
S := FCommentMarkers.Names[I];
if (Length(S) = 1) then
PS^ := FCommentMarkers.Values[S]
else begin
PS^ := ':1' + S[2] + ';' + FCommentMarkers.Values[S];
S := S[1];
end;
if (not CommentDict.Exists(S, P)) then
CommentDict.Add(S, PS)
else begin
AStr := String(P^);
AStr := AStr + PS^;
String(P^) := AStr;
CommentDict.Update(S, P);
Dispose(PS);
end;
end else
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
end;
for I := 0 to pred(FEmbeddedHTML.Count) do begin
if (pos('=', FEmbeddedHTML[I]) > 0) then begin
New(PS);
S := FEmbeddedHTML.Names[I];
PS^ := FEmbeddedHTML.Values[S];
if (not HTMLDict.Exists(S, P)) then
HTMLDict.Add(S, PS)
else
Dispose(PS);
end else
RaiseStError(EStToHTMLError, stscInvalidSLEntry);
end;
BRead := 0;
if (FPageHeader.Count > 0) then begin
for I := 0 to pred(FPageHeader.Count) do
FOutTextStream.WriteLine(FPageHeader[I]);
end;
FOutTextStream.WriteLine('<pre>');
CommentPend := False;
AStr := '';
SStr := '';
EStr := '';
{make sure buffer is at the start}
FInTextStream.Position := 0;
while not FInTextStream.AtEndOfStream do begin
TmpStr := FInTextStream.ReadLine;
Inc(BRead, Length(TmpStr) + Length(FInTextStream.LineTermChar));
if (FInFileSize > 0) then begin
PC := Round((BRead / FInFileSize * 100));
if (Assigned(FOnProgress)) then
FOnProgress(Self, PC);
end;
if (TmpStr = '') then begin
if (CommentPend) then
FOutTextStream.WriteLine(EStr)
else
FOutTextStream.WriteLine(' ');
continue;
end;
if (CommentPend) then
S := SStr
else
S := '';
P1 := 1;
repeat
if (not CommentPend) and (CommentDict.Exists(TmpStr[P1], P)) then begin
VS := String(P^);
if (Copy(VS, 1 , 2) = ':1') then begin
while (Copy(VS, 1 , 2) = ':1') do begin
System.Delete(VS, 1, 2);
if (TmpStr[P1+1] = VS[1]) then begin
System.Delete(VS, 1, 2);
CloseStr := Copy(VS, 1, pos(';', VS)-1);
System.Delete(VS, 1, pos(';', VS));
SStr := Copy(VS, 1, pos(';', VS)-1);
System.Delete(VS, 1, pos(';', VS));
J := pos(':1', VS);
if (J = 0) then
EStr := Copy(VS, pos(';', VS)+1, Length(VS))
else begin
EStr := Copy(VS, 1, J-1);
System.Delete(VS, 1, J+2);
end;
if (CloseStr = '') then begin
S := S + SStr;
AStr := Copy(TmpStr, P1, Length(TmpStr));
CheckSubString(AStr);
S := S + EStr;
CloseStr := '';
SStr := '';
EStr := '';
TmpStr := '';
continue;
end else begin
I := pos(CloseStr, TmpStr);
if (I = 0) then begin
CommentPend := True;
S := SStr + S;
end else begin
S := S + SStr;
AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
CheckSubstring(AStr);
S := S + EStr;
System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
end;
end;
end else begin
J := pos(':1', VS);
if (J > 0) then
System.Delete(VS, 1, J-1);
end;
end;
end else begin
{is it really the beginning of a comment?}
CloseStr := Copy(VS, 1, pos(';', VS)-1);
System.Delete(VS, 1, pos(';', VS));
SStr := Copy(VS, 1, pos(';', VS)-1);
EStr := Copy(VS, pos(';', VS)+1, Length(VS));
I := pos(CloseStr, TmpStr);
if (I > 0) and (I > P1) then begin
{ending marker found}
CommentPend := False;
S := S + SStr;
AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
CheckSubstring(AStr);
S := S + EStr;
System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
P1 := 1;
CloseStr := '';
SStr := '';
EStr := '';
if (TmpStr = '') then
continue;
end else begin {1}
CommentPend := True;
S := S + SStr;
if (Length(TmpStr) > 1) then begin
AStr := Copy(TmpStr, P1, Length(TmpStr));
CheckSubstring(AStr);
end else
S := S + TmpStr;
S := S + EStr;
TmpStr := '';
continue;
end;
end;
end;
if (CommentPend) then begin
I := pos(CloseStr, TmpStr);
if (I < 1) then begin
AStr := Copy(TmpStr, P1, Length(TmpStr));
CheckSubstring(AStr);
S := S + EStr;
TmpStr := '';
continue;
end else begin {2}
CommentPend := False;
if (Length(TmpStr) > 1) then begin
AStr := Copy(TmpStr, P1, I-P1+Length(CloseStr));
CheckSubstring(AStr);
end else
S := S + TmpStr;
S := S + EStr;
System.Delete(TmpStr, P1, I-P1+Length(CloseStr));
CloseStr := '';
SStr := '';
EStr := '';
if (TmpStr = '') then
continue
else
P1 := 1;
end;
end else begin
CloseStr := '';
SStr := '';
EStr := '';
end;
if (TmpStr = '') then
continue;
P := nil;
while (P1 <= Length(TmpStr)) and (pos(TmpStr[P1], FWordDelims) = 0) and
(not StringDict.Exists(TmpStr[P1], P)) do
Inc(P1);
if (Assigned(P)) then begin
P2 := P1+1;
VS := String(P^);
CloseStr := Copy(VS, 1, pos(';', VS)-1);
System.Delete(VS, 1, pos(';', VS));
SStr := Copy(VS, 1, pos(';', VS)-1);
System.Delete(VS, 1, pos(';', VS));
EStr := Copy(VS, pos(';', VS)+1, Length(VS));
while (TmpStr[P2] <> CloseStr) and (P2 <= Length(TmpStr)) do
Inc(P2);
S := S + SStr;
AStr := Copy(TmpStr, P1, P2-P1+1);
CheckSubString(AStr);
S := S + EStr;
System.Delete(TmpStr, P1, P2);
if (TmpStr = '') then
continue
else
P1 := 1;
P := nil;
end else if (P1 <= Length(TmpStr)) and (pos(TmpStr[P1], FWordDelims) > 0) then begin
if (P1 = 1) then begin
S := S + ConvertEmbeddedHTML(TmpStr[1]);
System.Delete(TmpStr, 1, 1);
P1 := 1;
end else begin
AStr := Copy(TmpStr, 1, P1-1);
if (Length(AStr) > 0) then
CheckSubstring(AStr);
System.Delete(TmpStr, 1, P1);
P1 := 1;
end;
end else begin
AStr := TmpStr;
CheckSubString(AStr);
TmpStr := '';
end;
until (Length(TmpStr) = 0);
FOutTextStream.WriteLine(S);
end;
if (Assigned(FOnProgress)) then
FOnProgress(Self, 0);
Result := True;
FOutTextStream.WriteLine('</pre>');
if (FPageFooter.Count > 0) then begin
for I := 0 to pred(FPageFooter.Count) do
FOutTextStream.WriteLine(FPageFooter[I]);
end;
finally
CommentDict.Free;
HTMLDict.Free;
KeywordsDict.Free;
StringDict.Free;
FInTextStream.Free;
FInTextStream := nil;
FOutTextStream.Free;
FOutTextStream := nil;
end;
end;
procedure TStStreamToHTML.SetCommentMarkers(Value : TStringList);
begin
FCommentMarkers.Assign(Value);
end;
procedure TStStreamToHTML.SetEmbeddedHTML(Value : TStringList);
begin
FEmbeddedHTML.Assign(Value);
end;
procedure TStStreamToHTML.SetKeywords(Value : TStringList);
begin
FKeywords.Assign(Value);
end;
procedure TStStreamToHTML.SetPageFooter(Value : TStringList);
begin
FPageFooter.Assign(Value);
end;
procedure TStStreamToHTML.SetPageHeader(Value : TStringList);
begin
FPageHeader.Assign(Value);
end;
procedure TStStreamToHTML.SetStringMarkers(Value : TStringList);
begin
FStringMarkers.Assign(Value);
end;
(*****************************************************************************)
(* TStFileToHTML Implementation *)
(*****************************************************************************)
constructor TStFileToHTML.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
FCommentMarkers := TStringList.Create;
FEmbeddedHTML := TStringList.Create;
FKeywords := TStringList.Create;
FPageFooter := TStringList.Create;
FPageHeader := TStringList.Create;
FStringMarkers := TStringList.Create;
FWordDelims := ',; .()';
FInLineTerminator := ltCRLF;
FInLineTermChar := #10;
FInLineLength := 80;
with FEmbeddedHTML do begin
Add('"=&quot;');
Add('&=&amp;');
Add('<=&lt;');
Add('>=&gt;');
Add('�=&iexcl;');
Add('�=&cent;');
Add('�=&pound;');
Add('�=&copy;');
Add('�=&reg;');
Add('�=&plusmn;');
Add('�=&frac14;');
Add('�=&frac12;');
Add('�=&frac34;');
Add('�=&divide;');
end;
end;
destructor TStFileToHTML.Destroy;
begin
FCommentMarkers.Free;
FCommentMarkers := nil;
FEmbeddedHTML.Free;
FEmbeddedHTML := nil;
FKeywords.Free;
FKeywords := nil;
FPageFooter.Free;
FPageFooter := nil;
FPageHeader.Free;
FPageHeader := nil;
FStringMarkers.Free;
FStringMarkers := nil;
FInFile.Free;
FInFile := nil;
FOutFile.Free;
FOutFile := nil;
FStream.Free;
FStream := nil;
inherited Destroy;
end;
procedure TStFileToHTML.Execute;
begin
FStream := TStStreamToHTML.Create;
try
if (FInFileName = '') then
RaiseStError(EStToHTMLError, stscNoInputFile)
else if (FOutFileName = '') then
RaiseStError(EStToHTMLError, stscNoOutputFile)
else begin
if (Assigned(FInFile)) then
FInFile.Free;
try
FInFile := TFileStream.Create(FInFileName, fmOpenRead or fmShareDenyWrite);
except
RaiseStError(EStToHTMLError, stscInFileError);
Exit;
end;
if (Assigned(FOutFile)) then
FOutFile.Free;
try
FOutFile := TFileStream.Create(FOutFileName, fmCreate);
except
RaiseStError(EStToHTMLError, stscOutFileError);
Exit;
end;
try
FStream.InputStream := FInFile;
FStream.OutputStream := FOutFile;
FStream.CaseSensitive := CaseSensitive;
FStream.CommentMarkers := CommentMarkers;
FStream.EmbeddedHTML := EmbeddedHTML;
FStream.InFixedLineLength := InFixedLineLength;
FStream.InLineTermChar := InLineTermChar;
FStream.InLineTerminator := InLineTerminator;
FStream.Keywords := Keywords;
FStream.OnProgress := OnProgress;
FStream.PageFooter := PageFooter;
FStream.PageHeader := PageHeader;
FStream.StringMarkers := StringMarkers;
FStream.WordDelimiters := WordDelimiters;
FStream.GenerateHTML;
finally
FInFile.Free;
FInFile := nil;
FOutFile.Free;
FOutFile := nil;
end;
end;
finally
FStream.Free;
FStream := nil;
end;
end;
procedure TStFileToHTML.SetCommentMarkers(Value : TStringList);
begin
FCommentMarkers.Assign(Value);
end;
procedure TStFileToHTML.SetEmbeddedHTML(Value : TStringList);
begin
FEmbeddedHTML.Assign(Value);
end;
procedure TStFileToHTML.SetKeywords(Value : TStringList);
begin
FKeywords.Assign(Value);
end;
procedure TStFileToHTML.SetPageFooter(Value : TStringList);
begin
FPageFooter.Assign(Value);
end;
procedure TStFileToHTML.SetPageHeader(Value : TStringList);
begin
FPageHeader.Assign(Value);
end;
procedure TStFileToHTML.SetStringMarkers(Value : TStringList);
begin
FStringMarkers.Assign(Value);
end;
end.

439
components/systools/source/run/stutils.pas Normal file
View File

@ -0,0 +1,439 @@
// Upgraded to Delphi 2009: Sebastian Zierer
(* ***** 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 ***** *)
{*********************************************************}
{* SysTools: StUtils.pas 4.04 *}
{*********************************************************}
{* SysTools: Assorted utility routines *}
{*********************************************************}
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
// {$I StDefine.inc}
unit StUtils;
interface
uses
{$IFNDEF FPC}
Windows,
{$ENDIF}
SysUtils, Classes,
StConst, StBase, StDate,
StStrL; { long string routines }
function SignL(L : LongInt) : Integer;
{-return sign of LongInt value}
function SignF(F : Extended) : Integer;
{-return sign of floating point value}
function MinWord(A, B : Word) : Word;
{-Return the smaller of A and B}
function MidWord(W1, W2, W3 : Word) : Word;
{-return the middle of three Word values}
function MaxWord(A, B : Word) : Word;
{-Return the greater of A and B}
function MinLong(A, B : LongInt) : LongInt;
{-Return the smaller of A and B}
function MidLong(L1, L2, L3 : LongInt) : LongInt;
{-return the middle of three LongInt values}
function MaxLong(A, B : LongInt) : LongInt;
{-Return the greater of A and B}
function MinFloat(F1, F2 : Extended) : Extended;
{-return the lesser of two floating point values}
function MidFloat(F1, F2, F3 : Extended) : Extended;
{-return the middle of three floating point values}
function MaxFloat(F1, F2 : Extended) : Extended;
{-return the greater of two floating point values}
{-Assorted utility routines. }
function MakeInteger16(H, L : Byte): SmallInt;
{-Construct an integer from two bytes}
function MakeWord(H, L : Byte) : Word;
{-Construct a word from two bytes}
function SwapNibble(B : Byte) : Byte;
{-Swap the high and low nibbles of a byte}
function SwapWord(L : LongInt) : LongInt;
{-Swap the low- and high-order words of a long integer}
procedure SetFlag(var Flags : Word; FlagMask : Word);
{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
procedure ClearFlag(var Flags : Word; FlagMask : Word);
{-Clear bit(s) in the parameter Flags. The bits to clear are specified in Flagmask}
function FlagIsSet(Flags, FlagMask : Word) : Boolean;
{-Return True if the bit specified by FlagMask is set in Flags}
procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
{-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
{-Return True if the bit specified by FlagMask is set in the Flags parameter}
procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
{-Set bit(s) in the parameter Flags. The bits to set are specified in FlagMask}
procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
{-Clear bit(s) in the parameter Flags. The bits to clear are specified in FlagMask}
function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
{-Return True if the bit specified by FlagMask is set in Flags}
procedure ExchangeBytes(var I, J : Byte);
{-Exchange the values in two bytes}
procedure ExchangeWords(var I, J : Word);
{-Exchange the values in two words}
procedure ExchangeLongInts(var I, J : LongInt);
{-Exchange the values in two long integers}
procedure ExchangeStructs(var I, J; Size : Cardinal);
{-Exchange the values in two structures}
procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
{-Fill memory with a word-sized filler}
procedure FillStruct(var Dest; Count : Cardinal; var Filler; FillerSize : Cardinal);
{-Fill memory with a variable sized filler}
function AddWordToPtr(P : Pointer; W : Word) : Pointer;
{-Add a word to a pointer.}
implementation
const
ecOutOfMemory = 8;
function MakeInteger16(H, L : Byte): SmallInt;
begin
Word(Result) := (H shl 8) or L; {!!.02}
end;
function SwapNibble(B : Byte) : Byte;
begin
Result := (B shr 4) or (B shl 4);
end;
function SwapWord(L : LongInt) : LongInt; register;
asm
ror eax,16;
end;
procedure SetFlag(var Flags : Word; FlagMask : Word);
begin
Flags := Flags or FlagMask;
end;
procedure ClearFlag(var Flags : Word; FlagMask : Word);
begin
Flags := Flags and (not FlagMask);
end;
function FlagIsSet(Flags, FlagMask : Word) : Boolean;
begin
Result := (FlagMask AND Flags <> 0);
end;
procedure SetByteFlag(var Flags : Byte; FlagMask : Byte);
begin
Flags := Flags or FlagMask;
end;
procedure ClearByteFlag(var Flags : Byte; FlagMask : Byte);
begin
Flags := Flags and (not FlagMask);
end;
function ByteFlagIsSet(Flags, FlagMask : Byte) : Boolean;
begin
Result := (FlagMask AND Flags <> 0);
end;
procedure SetLongFlag(var Flags : LongInt; FlagMask : LongInt);
begin
Flags := Flags or FlagMask;
end;
procedure ClearLongFlag(var Flags : LongInt; FlagMask : LongInt);
begin
Flags := Flags and (not FlagMask);
end;
function LongFlagIsSet(Flags, FlagMask : LongInt) : Boolean;
begin
Result := FlagMask = (Flags and FlagMask);
end;
procedure ExchangeBytes(var I, J : Byte);
register;
asm
mov cl, [eax]
mov ch, [edx]
mov [edx], cl
mov [eax], ch
end;
procedure ExchangeWords(var I, J : Word);
register;
asm
mov cx, [eax]
push ecx
mov cx, [edx]
mov [eax], cx
pop ecx
mov [edx], cx
end;
procedure ExchangeLongInts(var I, J : LongInt);
register;
asm
mov ecx, [eax]
push ecx
mov ecx, [edx]
mov [eax], ecx
pop ecx
mov [edx], ecx
end;
procedure ExchangeStructs(var I, J; Size : Cardinal);
register;
asm
push edi
push ebx
push ecx
shr ecx, 2
jz @@LessThanFour
@@AgainDWords:
mov ebx, [eax]
mov edi, [edx]
mov [edx], ebx
mov [eax], edi
add eax, 4
add edx, 4
dec ecx
jnz @@AgainDWords
@@LessThanFour:
pop ecx
and ecx, $3
jz @@Done
mov bl, [eax]
mov bh, [edx]
mov [edx], bl
mov [eax], bh
inc eax
inc edx
dec ecx
jz @@Done
mov bl, [eax]
mov bh, [edx]
mov [edx], bl
mov [eax], bh
inc eax
inc edx
dec ecx
jz @@Done
mov bl, [eax]
mov bh, [edx]
mov [edx], bl
mov [eax], bh
@@Done:
pop ebx
pop edi
end;
procedure FillWord(var Dest; Count : Cardinal; Filler : Word);
asm
push edi
mov edi,Dest
mov ax,Filler
mov ecx,Count
cld
rep stosw
pop edi
end;
procedure FillStruct(var Dest; Count : Cardinal; var Filler;
FillerSize : Cardinal);
register;
asm
or edx, edx
jz @@Exit
push edi
push esi
push ebx
mov edi, eax
mov ebx, ecx
@@NextStruct:
mov esi, ebx
mov ecx, FillerSize
shr ecx, 1
rep movsw
adc ecx, ecx
rep movsb
dec edx
jnz @@NextStruct
pop ebx
pop esi
pop edi
@@Exit:
end;
function AddWordToPtr(P : Pointer; W : Word) : Pointer;
begin
Result := Pointer(LongInt(P)+W);
end;
function MakeWord(H, L : Byte) : Word;
begin
Result := (Word(H) shl 8) or L;
end;
function MinWord(A, B : Word) : Word;
begin
if A < B then
Result := A
else
Result := B;
end;
function MaxWord(A, B : Word) : Word;
begin
if A > B then
Result := A
else
Result := B;
end;
function MinLong(A, B : LongInt) : LongInt;
begin
if A < B then
Result := A
else
Result := B;
end;
function MaxLong(A, B : LongInt) : LongInt;
begin
if A > B then
Result := A
else
Result := B;
end;
function SignL(L : LongInt) : Integer;
{-return sign of LongInt value}
begin
if L < 0 then
Result := -1
else if L = 0 then
Result := 0
else
Result := 1;
end;
function SignF(F : Extended) : Integer;
{-return sign of floating point value}
begin
if F < 0 then
Result := -1
else if F = 0 then
Result := 0
else
Result := 1;
end;
function MidWord(W1, W2, W3 : Word) : Word;
{return the middle of three Word values}
begin
Result := StUtils.MinWord(StUtils.MinWord(StUtils.MaxWord(W1, W2),
StUtils.MaxWord(W2, W3)), StUtils.MaxWord(W1, W3));
end;
function MidLong(L1, L2, L3 : LongInt) : LongInt;
{return the middle of three LongInt values}
begin
Result := StUtils.MinLong(StUtils.MinLong(StUtils.MaxLong(L1, L2),
StUtils.MaxLong(L2, L3)), StUtils.MaxLong(L1, L3));
end;
function MidFloat(F1, F2, F3 : Extended) : Extended;
{return the middle of three floating point values}
begin
Result := MinFloat(MinFloat(MaxFloat(F1, F2), MaxFloat(F2, F3)), MaxFloat(F1, F3));
end;
function MinFloat(F1, F2 : Extended) : Extended;
{-return the lesser of two floating point values}
begin
if F1 <= F2 then
Result := F1
else
Result := F2;
end;
function MaxFloat(F1, F2 : Extended) : Extended;
{-return the greater of two floating point values}
begin
if F1 > F2 then
Result := F1
else
Result := F2;
end;
end.