You've already forked lazarus-ccr
jvcllaz: Add JvHtControls and JvValidators ported by Michal Gawrycki (issue #0031026). Fixed some Linux-related issued. Clean up of hints and warnings.
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5392 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
92
components/jvcllaz/examples/JvHTControls/JvHTCtrlsDemo.lpi
Normal file
92
components/jvcllaz/examples/JvHTControls/JvHTCtrlsDemo.lpi
Normal file
@ -0,0 +1,92 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="10"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="JvHTCtrlsDemo"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<XPManifest>
|
||||
<TextName Value="CompanyName.ProductName.AppName"/>
|
||||
<TextDesc Value="Your application description."/>
|
||||
</XPManifest>
|
||||
<Icon Value="0"/>
|
||||
</General>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="4">
|
||||
<Item1>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="MemDSLaz"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<PackageName Value="jvhtcontrolslaz"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item4>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="JvHTCtrlsDemo.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="unit1.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="Form1"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
<UnitName Value="Unit1"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="..\..\bin\JvHTCtrlsDemo"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<UseExternalDbgSyms Value="True"/>
|
||||
</Debugging>
|
||||
<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>
|
||||
21
components/jvcllaz/examples/JvHTControls/JvHTCtrlsDemo.lpr
Normal file
21
components/jvcllaz/examples/JvHTControls/JvHTCtrlsDemo.lpr
Normal file
@ -0,0 +1,21 @@
|
||||
program JvHTCtrlsDemo;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
uses
|
||||
{$IFDEF UNIX}{$IFDEF UseCThreads}
|
||||
cthreads,
|
||||
{$ENDIF}{$ENDIF}
|
||||
Interfaces, // this includes the LCL widgetset
|
||||
Forms, memdslaz, Unit1
|
||||
{ you can add units after this };
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
RequireDerivedFormResource:=True;
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TForm1, Form1);
|
||||
Application.Run;
|
||||
end.
|
||||
|
||||
269
components/jvcllaz/examples/JvHTControls/unit1.lfm
Normal file
269
components/jvcllaz/examples/JvHTControls/unit1.lfm
Normal file
@ -0,0 +1,269 @@
|
||||
object Form1: TForm1
|
||||
Left = 256
|
||||
Height = 468
|
||||
Top = 122
|
||||
Width = 582
|
||||
Caption = 'JvHTControls'
|
||||
ClientHeight = 468
|
||||
ClientWidth = 582
|
||||
OnCreate = FormCreate
|
||||
OnShow = FormShow
|
||||
LCLVersion = '1.7'
|
||||
object PageControl1: TPageControl
|
||||
Left = 0
|
||||
Height = 422
|
||||
Top = 0
|
||||
Width = 582
|
||||
ActivePage = TabSheet1
|
||||
Align = alClient
|
||||
TabIndex = 0
|
||||
TabOrder = 0
|
||||
object TabSheet1: TTabSheet
|
||||
Caption = 'TJvHTLabel'
|
||||
ClientHeight = 394
|
||||
ClientWidth = 574
|
||||
object JvHTLabel1: TJvHTLabel
|
||||
Left = 8
|
||||
Height = 106
|
||||
Hint = 'HTLabel with:<br>'#13#10'<b>bold</b><br>'#13#10'<i>italic</i><br>'#13#10'<u>underline</u><br>'#13#10'<s>strikeout</s><br>'#13#10'<font color="clRed">c</font><font color="clblue">o</font><font color="clGreen">l</font><font color="clFuchsia">o</font><font color="clMaroon">r</font><br>'#13#10'<a href="http://www.freepascal.org/">Links</a> and <a href="custom">custom links</a>'
|
||||
Top = 8
|
||||
Width = 120
|
||||
Caption = 'HTLabel with:<br>'#13#10'<b>bold</b><br>'#13#10'<i>italic</i><br>'#13#10'<u>underline</u><br>'#13#10'<s>strikeout</s><br>'#13#10'<font color="clRed">c</font><font color="clblue">o</font><font color="clGreen">l</font><font color="clFuchsia">o</font><font color="clMaroon">r</font><br>'#13#10'<a href="http://www.freepascal.org/">Links</a> and <a href="custom">custom links</a>'
|
||||
ParentColor = False
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
OnHyperLinkClick = JvHTLabel1HyperLinkClick
|
||||
end
|
||||
object Memo1: TMemo
|
||||
Left = 0
|
||||
Height = 122
|
||||
Hint = '<b>HTML</b><br>'#13#10'<i>Enter HTML content</i>'
|
||||
Top = 272
|
||||
Width = 574
|
||||
Align = alBottom
|
||||
Lines.Strings = (
|
||||
'HTLabel with:<br>'
|
||||
'<b>bold</b><br>'
|
||||
'<i>italic</i><br>'
|
||||
'<u>underline</u><br>'
|
||||
'<s>strikeout</s><br>'
|
||||
'<font color="clRed">c</font><font color="clblue">o</font><font color="clGreen">l</font><font color="clFuchsia">o</font><font color="clMaroon">r</font><br>'
|
||||
'<a href="http://www.freepascal.org/">Links</a> and <a href="custom">custom links</a>'
|
||||
)
|
||||
OnChange = Memo1Change
|
||||
ParentFont = False
|
||||
ParentShowHint = False
|
||||
ScrollBars = ssAutoBoth
|
||||
ShowHint = True
|
||||
TabOrder = 0
|
||||
WordWrap = False
|
||||
end
|
||||
object Splitter1: TSplitter
|
||||
Cursor = crVSplit
|
||||
Left = 0
|
||||
Height = 5
|
||||
Top = 267
|
||||
Width = 574
|
||||
Align = alBottom
|
||||
ResizeAnchor = akBottom
|
||||
end
|
||||
end
|
||||
object TabSheet2: TTabSheet
|
||||
Caption = 'TJvHTListBox'
|
||||
ClientHeight = 394
|
||||
ClientWidth = 574
|
||||
object JvHTListBox1: TJvHTListBox
|
||||
Left = 0
|
||||
Height = 394
|
||||
Hint = '<b>TJvHTListBox</b><br>'#13#10'<i>ListBox with HT items</i>'
|
||||
Top = 0
|
||||
Width = 152
|
||||
HideSel = False
|
||||
OnHyperLinkClick = JvHTListBox1HyperLinkClick
|
||||
Align = alLeft
|
||||
ColorHighlight = clHighlight
|
||||
ColorHighlightText = clHighlightText
|
||||
ColorDisabledText = clGrayText
|
||||
Items.Strings = (
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
)
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 0
|
||||
end
|
||||
object Splitter2: TSplitter
|
||||
Left = 152
|
||||
Height = 394
|
||||
Top = 0
|
||||
Width = 5
|
||||
end
|
||||
object Memo2: TMemo
|
||||
Left = 160
|
||||
Height = 90
|
||||
Hint = '<b>New item content</b><br><i>Enter new item contnent</i>'
|
||||
Top = 8
|
||||
Width = 406
|
||||
Anchors = [akTop, akLeft, akRight]
|
||||
Lines.Strings = (
|
||||
'new item...'
|
||||
)
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 2
|
||||
end
|
||||
object Button1: TButton
|
||||
Left = 160
|
||||
Height = 25
|
||||
Hint = '<b>Add item</b><br>'#13#10'<i>Add item to ListBox and ComboBox</i>'
|
||||
Top = 112
|
||||
Width = 75
|
||||
AutoSize = True
|
||||
Caption = 'Add item'
|
||||
OnClick = Button1Click
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 3
|
||||
end
|
||||
object JvHTComboBox1: TJvHTComboBox
|
||||
Left = 160
|
||||
Height = 24
|
||||
Hint = '<b>TJvHTComboBox</b><br>'#13#10'<i>ComboBox with HT items</i>'
|
||||
Top = 160
|
||||
Width = 152
|
||||
HideSel = False
|
||||
ColorHighlight = clHighlight
|
||||
ColorHighlightText = clHighlightText
|
||||
ColorDisabledText = clGrayText
|
||||
Items.Strings = (
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
'<b>Lazarus</b><br><a href="http://www.lazarus-ide.org/">Home page</a> or <a hred="http://forum.lazarus.freepascal.org/">Forum</a>'
|
||||
'<b>Free Pascal</b><br><a href="http://www.freepascal.org/">Home page</a>'
|
||||
'<b>Other...</b><br><i>Other stuff</i> <font color="clred">d-oh!</font>...'
|
||||
)
|
||||
ParentShowHint = False
|
||||
ShowHint = True
|
||||
TabOrder = 4
|
||||
Text = 'JvHTComboBox1'
|
||||
end
|
||||
object Button2: TButton
|
||||
Left = 264
|
||||
Height = 25
|
||||
Top = 112
|
||||
Width = 53
|
||||
AutoSize = True
|
||||
Caption = 'Clear'
|
||||
OnClick = Button2Click
|
||||
TabOrder = 5
|
||||
end
|
||||
end
|
||||
object TabSheet3: TTabSheet
|
||||
Caption = 'TJvDBHTLabel'
|
||||
ClientHeight = 394
|
||||
ClientWidth = 574
|
||||
object JvDBHTLabel1: TJvDBHTLabel
|
||||
Left = 8
|
||||
Height = 76
|
||||
Top = 8
|
||||
Width = 82
|
||||
DataSource = DataSource1
|
||||
Mask = 'Numeric field: <b><field="Num"></b><br>Field 1: <b><font color="clRed"><field="fld1"></font></b><br><i>Field 2:</i> <b><font color="clGreen"><field="fld2"></font></b><br>And some link: <a href="url"><field="Fld1"></a><br><a href="qwe">#<field="num"></a> - <b><field="fld1"> <field="fld2"></b>'
|
||||
ParentColor = False
|
||||
OnHyperLinkClick = JvDBHTLabel1HyperLinkClick
|
||||
end
|
||||
object DBGrid1: TDBGrid
|
||||
Left = 0
|
||||
Height = 130
|
||||
Top = 264
|
||||
Width = 574
|
||||
Align = alBottom
|
||||
Color = clWindow
|
||||
Columns = <>
|
||||
DataSource = DataSource1
|
||||
TabOrder = 0
|
||||
end
|
||||
object Splitter3: TSplitter
|
||||
Cursor = crVSplit
|
||||
Left = 0
|
||||
Height = 5
|
||||
Top = 259
|
||||
Width = 574
|
||||
Align = alBottom
|
||||
ResizeAnchor = akBottom
|
||||
end
|
||||
object Memo3: TMemo
|
||||
Left = 0
|
||||
Height = 99
|
||||
Top = 160
|
||||
Width = 574
|
||||
Align = alBottom
|
||||
Lines.Strings = (
|
||||
'Numeric field: <b><field="Num"></b><br>Field 1: <b><font color="clRed"><field="fld1"></font></b><br><i>Field 2:</i> <b><font color="clGreen"><field="fld2"></font></b><br>And some link: <a href="url"><field="Fld1"></a><br><a href="qwe">#<field="num"></a> - <b><field="fld1"> <field="fld2"></b>'
|
||||
)
|
||||
OnChange = Memo3Change
|
||||
TabOrder = 2
|
||||
end
|
||||
end
|
||||
end
|
||||
object ButtonPanel1: TButtonPanel
|
||||
Left = 6
|
||||
Height = 34
|
||||
Top = 428
|
||||
Width = 570
|
||||
OKButton.Name = 'OKButton'
|
||||
OKButton.DefaultCaption = True
|
||||
HelpButton.Name = 'HelpButton'
|
||||
HelpButton.DefaultCaption = True
|
||||
CloseButton.Name = 'CloseButton'
|
||||
CloseButton.Hint = '<b>Exit</b><br>'#13#10'<i>Exit application</i>'
|
||||
CloseButton.DefaultCaption = True
|
||||
CloseButton.ShowHint = True
|
||||
CancelButton.Name = 'CancelButton'
|
||||
CancelButton.DefaultCaption = True
|
||||
TabOrder = 1
|
||||
ShowButtons = [pbClose]
|
||||
end
|
||||
object MemDataset1: TMemDataset
|
||||
Active = True
|
||||
FieldDefs = <
|
||||
item
|
||||
Name = 'Num'
|
||||
DataType = ftInteger
|
||||
end
|
||||
item
|
||||
Name = 'Fld1'
|
||||
DataType = ftString
|
||||
Size = 20
|
||||
end
|
||||
item
|
||||
Name = 'Fld2'
|
||||
DataType = ftString
|
||||
Size = 20
|
||||
end>
|
||||
left = 384
|
||||
top = 112
|
||||
end
|
||||
object DataSource1: TDataSource
|
||||
DataSet = MemDataset1
|
||||
left = 464
|
||||
top = 112
|
||||
end
|
||||
end
|
||||
114
components/jvcllaz/examples/JvHTControls/unit1.pas
Normal file
114
components/jvcllaz/examples/JvHTControls/unit1.pas
Normal file
@ -0,0 +1,114 @@
|
||||
unit Unit1;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
|
||||
StdCtrls, ButtonPanel, ExtCtrls, DBGrids, JvHtControls, JvHint, JvDBHTLabel,
|
||||
memds, db;
|
||||
|
||||
type
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
TForm1 = class(TForm)
|
||||
Button1: TButton;
|
||||
Button2: TButton;
|
||||
ButtonPanel1: TButtonPanel;
|
||||
DataSource1: TDataSource;
|
||||
DBGrid1: TDBGrid;
|
||||
JvDBHTLabel1: TJvDBHTLabel;
|
||||
JvHTComboBox1: TJvHTComboBox;
|
||||
JvHTLabel1: TJvHTLabel;
|
||||
JvHTListBox1: TJvHTListBox;
|
||||
MemDataset1: TMemDataset;
|
||||
Memo1: TMemo;
|
||||
Memo2: TMemo;
|
||||
Memo3: TMemo;
|
||||
PageControl1: TPageControl;
|
||||
Splitter1: TSplitter;
|
||||
Splitter2: TSplitter;
|
||||
Splitter3: TSplitter;
|
||||
TabSheet1: TTabSheet;
|
||||
TabSheet2: TTabSheet;
|
||||
TabSheet3: TTabSheet;
|
||||
procedure Button1Click(Sender: TObject);
|
||||
procedure Button2Click(Sender: TObject);
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure FormShow(Sender: TObject);
|
||||
procedure JvDBHTLabel1HyperLinkClick(Sender: TObject; LinkName: string);
|
||||
procedure JvHTLabel1HyperLinkClick(Sender: TObject; LinkName: string);
|
||||
procedure JvHTListBox1HyperLinkClick(Sender: TObject; LinkName: string);
|
||||
procedure Memo1Change(Sender: TObject);
|
||||
procedure Memo3Change(Sender: TObject);
|
||||
private
|
||||
|
||||
public
|
||||
|
||||
end;
|
||||
|
||||
var
|
||||
Form1: TForm1;
|
||||
|
||||
implementation
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
{ TForm1 }
|
||||
|
||||
procedure TForm1.Memo1Change(Sender: TObject);
|
||||
begin
|
||||
JvHTLabel1.Caption := Memo1.Text;
|
||||
JvHTLabel1.Hint := Memo1.Text;
|
||||
end;
|
||||
|
||||
procedure TForm1.Memo3Change(Sender: TObject);
|
||||
begin
|
||||
JvDBHTLabel1.Mask := Memo3.Text;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormCreate(Sender: TObject);
|
||||
begin
|
||||
RegisterHtHints;
|
||||
end;
|
||||
|
||||
procedure TForm1.FormShow(Sender: TObject);
|
||||
begin
|
||||
MemDataset1.AppendRecord([1, 'asdfxc', 'wertfx']);
|
||||
MemDataset1.AppendRecord([2, 'brdrgrsdgx', 'sdfwetrcx']);
|
||||
MemDataset1.AppendRecord([3, 'bhtesdxcv', 'wytsfsv']);
|
||||
MemDataset1.AppendRecord([4, 'sdgrdthc', 'klvbsdfwe85']);
|
||||
MemDataset1.AppendRecord([5, 'trcbxg', 'her4fekg']);
|
||||
end;
|
||||
|
||||
procedure TForm1.JvDBHTLabel1HyperLinkClick(Sender: TObject; LinkName: string);
|
||||
begin
|
||||
MessageDlg('TJvDBHTLabel', 'Hyperlink: ' + LinkName, mtInformation, [mbOK], 0);
|
||||
end;
|
||||
|
||||
procedure TForm1.Button1Click(Sender: TObject);
|
||||
begin
|
||||
JvHTListBox1.Items.Add(Memo2.Text);
|
||||
JvHTComboBox1.Items.Add(Memo2.Text);
|
||||
end;
|
||||
|
||||
procedure TForm1.Button2Click(Sender: TObject);
|
||||
begin
|
||||
JvHTComboBox1.Items.Clear;
|
||||
JvHTListBox1.Items.Clear;
|
||||
end;
|
||||
|
||||
procedure TForm1.JvHTLabel1HyperLinkClick(Sender: TObject; LinkName: string);
|
||||
begin
|
||||
MessageDlg('TJvHTLabel', 'Hyperlink: ' + LinkName, mtInformation, [mbOK], 0);
|
||||
end;
|
||||
|
||||
procedure TForm1.JvHTListBox1HyperLinkClick(Sender: TObject; LinkName: string);
|
||||
begin
|
||||
MessageDlg('JvHTListBox', 'Hyperlink: ' + LinkName, mtInformation, [mbOK], 0);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
102
components/jvcllaz/examples/JvValidators/JvValidatorsDemo.lpi
Normal file
102
components/jvcllaz/examples/JvValidators/JvValidatorsDemo.lpi
Normal file
@ -0,0 +1,102 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<ProjectOptions>
|
||||
<Version Value="10"/>
|
||||
<PathDelim Value="\"/>
|
||||
<General>
|
||||
<Flags>
|
||||
<MainUnitHasUsesSectionForAllUnits Value="False"/>
|
||||
<MainUnitHasCreateFormStatements Value="False"/>
|
||||
<MainUnitHasTitleStatement Value="False"/>
|
||||
</Flags>
|
||||
<SessionStorage Value="InProjectDir"/>
|
||||
<MainUnit Value="0"/>
|
||||
<Title Value="JvValidatorsDemo"/>
|
||||
<UseAppBundle Value="False"/>
|
||||
<ResourceType Value="res"/>
|
||||
<UseXPManifest Value="True"/>
|
||||
<XPManifest>
|
||||
<TextName Value="CompanyName.ProductName.AppName"/>
|
||||
<TextDesc Value="Your application description."/>
|
||||
</XPManifest>
|
||||
</General>
|
||||
<i18n>
|
||||
<EnableI18N LFM="False"/>
|
||||
</i18n>
|
||||
<BuildModes Count="1">
|
||||
<Item1 Name="Default" Default="True"/>
|
||||
</BuildModes>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<RunParams>
|
||||
<local>
|
||||
<FormatVersion Value="1"/>
|
||||
</local>
|
||||
</RunParams>
|
||||
<RequiredPackages Count="2">
|
||||
<Item1>
|
||||
<PackageName Value="JvValidatorLaz"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="LCL"/>
|
||||
</Item2>
|
||||
</RequiredPackages>
|
||||
<Units Count="2">
|
||||
<Unit0>
|
||||
<Filename Value="JvValidatorsDemo.lpr"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
</Unit0>
|
||||
<Unit1>
|
||||
<Filename Value="MainFrm.pas"/>
|
||||
<IsPartOfProject Value="True"/>
|
||||
<ComponentName Value="frmMain"/>
|
||||
<HasResources Value="True"/>
|
||||
<ResourceBaseClass Value="Form"/>
|
||||
</Unit1>
|
||||
</Units>
|
||||
</ProjectOptions>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<Target>
|
||||
<Filename Value="..\..\bin\JvValidatorsDemo"/>
|
||||
</Target>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="$(ProjOutDir)"/>
|
||||
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
<ObjectPath Value="..\..\run"/>
|
||||
</SearchPaths>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<SyntaxMode Value="Delphi"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
<Linking>
|
||||
<Debugging>
|
||||
<UseExternalDbgSyms Value="True"/>
|
||||
</Debugging>
|
||||
<Options>
|
||||
<Win32>
|
||||
<GraphicApplication Value="True"/>
|
||||
</Win32>
|
||||
</Options>
|
||||
</Linking>
|
||||
<Other>
|
||||
<CustomOptions Value="-dBorland -dVer150 -dDelphi7 -dCompiler6_Up -dPUREPASCAL"/>
|
||||
</Other>
|
||||
</CompilerOptions>
|
||||
<Debugging>
|
||||
<Exceptions Count="3">
|
||||
<Item1>
|
||||
<Name Value="EAbort"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Name Value="ECodetoolError"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Name Value="EFOpenError"/>
|
||||
</Item3>
|
||||
</Exceptions>
|
||||
</Debugging>
|
||||
</CONFIG>
|
||||
@ -0,0 +1,15 @@
|
||||
program JvValidatorsDemo;
|
||||
|
||||
{$MODE Delphi}
|
||||
|
||||
uses
|
||||
Forms, Interfaces,
|
||||
MainFrm in 'MainFrm.pas' {frmMain};
|
||||
|
||||
{$R *.res}
|
||||
|
||||
begin
|
||||
Application.Initialize;
|
||||
Application.CreateForm(TfrmMain, frmMain);
|
||||
Application.Run;
|
||||
end.
|
||||
208
components/jvcllaz/examples/JvValidators/MainFrm.lfm
Normal file
208
components/jvcllaz/examples/JvValidators/MainFrm.lfm
Normal file
@ -0,0 +1,208 @@
|
||||
object frmMain: TfrmMain
|
||||
Left = 306
|
||||
Height = 274
|
||||
Top = 126
|
||||
Width = 619
|
||||
Caption = 'JvValidators demo'
|
||||
ClientHeight = 274
|
||||
ClientWidth = 619
|
||||
Color = clBtnFace
|
||||
Constraints.MinHeight = 270
|
||||
Constraints.MinWidth = 560
|
||||
DefaultMonitor = dmDesktop
|
||||
Font.Color = clWindowText
|
||||
OnCreate = FormCreate
|
||||
Position = poScreenCenter
|
||||
LCLVersion = '1.7'
|
||||
object Label1: TLabel
|
||||
Left = 16
|
||||
Height = 15
|
||||
Top = 16
|
||||
Width = 167
|
||||
Caption = 'This edit must have a(ny) value:'
|
||||
FocusControl = edRequired
|
||||
ParentColor = False
|
||||
end
|
||||
object Label2: TLabel
|
||||
Left = 16
|
||||
Height = 15
|
||||
Top = 64
|
||||
Width = 233
|
||||
Caption = 'This edit must have more than 9 characters:'
|
||||
FocusControl = edRequired10Chars
|
||||
ParentColor = False
|
||||
end
|
||||
object Label3: TLabel
|
||||
Left = 16
|
||||
Height = 15
|
||||
Top = 112
|
||||
Width = 228
|
||||
Caption = 'This edit must match the reg. expr."A.B.C.":'
|
||||
FocusControl = edRegExpr
|
||||
ParentColor = False
|
||||
end
|
||||
object Label4: TLabel
|
||||
Left = 16
|
||||
Height = 15
|
||||
Top = 160
|
||||
Width = 201
|
||||
Caption = 'The value must be between 0 and 100:'
|
||||
FocusControl = edRange0to100
|
||||
ParentColor = False
|
||||
end
|
||||
object Label5: TLabel
|
||||
Left = 280
|
||||
Height = 15
|
||||
Top = 16
|
||||
Width = 35
|
||||
Caption = 'Result:'
|
||||
ParentColor = False
|
||||
end
|
||||
object edRequired: TEdit
|
||||
Left = 16
|
||||
Height = 23
|
||||
Top = 32
|
||||
Width = 240
|
||||
TabOrder = 0
|
||||
end
|
||||
object edRequired10Chars: TEdit
|
||||
Left = 16
|
||||
Height = 23
|
||||
Top = 80
|
||||
Width = 240
|
||||
TabOrder = 1
|
||||
end
|
||||
object edRegExpr: TEdit
|
||||
Left = 16
|
||||
Height = 23
|
||||
Top = 128
|
||||
Width = 240
|
||||
TabOrder = 2
|
||||
end
|
||||
object edRange0to100: TEdit
|
||||
Left = 16
|
||||
Height = 23
|
||||
Top = 176
|
||||
Width = 227
|
||||
TabOrder = 3
|
||||
Text = '-1'
|
||||
end
|
||||
object udRange0to100: TUpDown
|
||||
Left = 243
|
||||
Height = 23
|
||||
Top = 176
|
||||
Width = 15
|
||||
Associate = edRange0to100
|
||||
Max = 200
|
||||
Min = -100
|
||||
Position = -1
|
||||
TabOrder = 4
|
||||
Wrap = False
|
||||
end
|
||||
object btnCheck: TButton
|
||||
Left = 336
|
||||
Height = 25
|
||||
Top = 224
|
||||
Width = 137
|
||||
Anchors = [akLeft, akBottom]
|
||||
AutoSize = True
|
||||
Caption = 'Use OnValidateFailed'
|
||||
OnClick = btnCheckClick
|
||||
TabOrder = 7
|
||||
end
|
||||
object btnProviderCheck: TButton
|
||||
Left = 16
|
||||
Height = 25
|
||||
Top = 224
|
||||
Width = 130
|
||||
Anchors = [akLeft, akBottom]
|
||||
AutoSize = True
|
||||
Caption = 'Use JvErrorIndicator'
|
||||
OnClick = btnProviderCheckClick
|
||||
TabOrder = 5
|
||||
end
|
||||
object reResults: TMemo
|
||||
Cursor = crArrow
|
||||
Left = 280
|
||||
Height = 167
|
||||
Top = 32
|
||||
Width = 326
|
||||
Anchors = [akTop, akLeft, akRight, akBottom]
|
||||
Lines.Strings = (
|
||||
'This is a demo for the JvValidators component as well as the JvErrorProvider and, to some extent, the JvValidationSummary component.'
|
||||
''
|
||||
'By creating and setting up different validators (at run-time in this demo but you can do it at design-time as well), the edit boxes can be checked for validity by a single call to the Validate method. When one of the validators finds that a control doesn''t match the validation criteria, that error can be handled in different ways depending on your needs.'
|
||||
''
|
||||
'One option is to just check the boolean return value from Validate and display a standard message box telling the user that a value didn''t match.'
|
||||
''
|
||||
'You can also handle the OnValidateFailed event of all validators at once (the TJvValidators event) or for each validator separately (the TJvBaseValidator event). Yet another option is to assign a TJvValidationSummary component to the ValidationSummary property of tJvValidators and handle it''s OnChange event.'
|
||||
''
|
||||
'Finally, you can combine the work of the validators with the use of a TJvErrorIndicator.'
|
||||
''
|
||||
'For more info on TJvErrorIndicator, see the demo for that component (also included).'
|
||||
''
|
||||
'By clicking any of the buttons below, you can see how the different methods described work in real-time.'
|
||||
''
|
||||
''
|
||||
)
|
||||
OnEnter = reResultsEnter
|
||||
ParentColor = True
|
||||
ReadOnly = True
|
||||
ScrollBars = ssBoth
|
||||
TabOrder = 8
|
||||
TabStop = False
|
||||
WordWrap = False
|
||||
end
|
||||
object btnValSum: TButton
|
||||
Left = 160
|
||||
Height = 25
|
||||
Top = 224
|
||||
Width = 162
|
||||
Anchors = [akLeft, akBottom]
|
||||
AutoSize = True
|
||||
Caption = 'Use JvValidationSummary'
|
||||
OnClick = btnValSumClick
|
||||
TabOrder = 6
|
||||
end
|
||||
object JvValidators1: TJvValidators
|
||||
OnValidateFailed = JvValidators1ValidateFailed
|
||||
left = 258
|
||||
top = 104
|
||||
object JvRequiredFieldValidator1: TJvRequiredFieldValidator
|
||||
ControlToValidate = edRequired
|
||||
PropertyToValidate = 'Text'
|
||||
ErrorMessage = 'Value in edRequired cannot be empty'
|
||||
AllowBlank = False
|
||||
end
|
||||
object JvCustomValidator1: TJvCustomValidator
|
||||
ControlToValidate = edRequired10Chars
|
||||
PropertyToValidate = 'Text'
|
||||
ErrorMessage = 'Value in "edRequired10Chars" requires at least 10 characters'
|
||||
OnValidate = JvCustomValidator1Validate
|
||||
end
|
||||
object JvRegularExpressionValidator1: TJvRegularExpressionValidator
|
||||
ControlToValidate = edRegExpr
|
||||
PropertyToValidate = 'Text'
|
||||
ErrorMessage = 'Value in "edRegExpr" does not match "A.B.C."'
|
||||
ValidationExpression = '^A.B.C.*'
|
||||
end
|
||||
object JvRangeValidator1: TJvRangeValidator
|
||||
ControlToValidate = udRange0to100
|
||||
PropertyToValidate = 'Position'
|
||||
ErrorMessage = 'Value in "udRange0to100" must be between 0 and 100'
|
||||
MinimumValue = 0
|
||||
MaximumValue = 100
|
||||
end
|
||||
end
|
||||
object JvErrorIndicator1: TJvErrorIndicator
|
||||
ImageIndex = 0
|
||||
DefaultUseAnchors = False
|
||||
left = 296
|
||||
top = 104
|
||||
end
|
||||
object JvValidationSummary1: TJvValidationSummary
|
||||
OnChange = JvValidationSummary1Change
|
||||
left = 328
|
||||
top = 104
|
||||
end
|
||||
end
|
||||
174
components/jvcllaz/examples/JvValidators/MainFrm.pas
Normal file
174
components/jvcllaz/examples/JvValidators/MainFrm.pas
Normal file
@ -0,0 +1,174 @@
|
||||
{******************************************************************
|
||||
|
||||
JEDI-VCL Demo
|
||||
|
||||
Copyright (C) 2002 Project JEDI
|
||||
|
||||
Original author:
|
||||
|
||||
Contributor(s):
|
||||
|
||||
You may retrieve the latest version of this file at the JEDI-JVCL
|
||||
home page, located at http://jvcl.delphi-jedi.org
|
||||
|
||||
The contents of this file are used with permission, 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/MPL-1_1Final.html
|
||||
|
||||
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.
|
||||
|
||||
******************************************************************}
|
||||
|
||||
unit MainFrm;
|
||||
|
||||
{.$I jvcl.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
|
||||
StdCtrls, ComCtrls, JvValidators, JvErrorIndicator;
|
||||
|
||||
type
|
||||
|
||||
{ TfrmMain }
|
||||
|
||||
TfrmMain = class(TForm)
|
||||
Label1: TLabel;
|
||||
edRequired: TEdit;
|
||||
Label2: TLabel;
|
||||
edRequired10Chars: TEdit;
|
||||
Label3: TLabel;
|
||||
edRegExpr: TEdit;
|
||||
Label4: TLabel;
|
||||
edRange0to100: TEdit;
|
||||
udRange0to100: TUpDown;
|
||||
btnCheck: TButton;
|
||||
Label5: TLabel;
|
||||
btnProviderCheck: TButton;
|
||||
reResults: TMemo;
|
||||
btnValSum: TButton;
|
||||
JvValidators1: TJvValidators;
|
||||
JvErrorIndicator1: TJvErrorIndicator;
|
||||
JvValidationSummary1: TJvValidationSummary;
|
||||
JvRequiredFieldValidator1: TJvRequiredFieldValidator;
|
||||
JvCustomValidator1: TJvCustomValidator;
|
||||
JvRegularExpressionValidator1: TJvRegularExpressionValidator;
|
||||
JvRangeValidator1: TJvRangeValidator;
|
||||
procedure FormCreate(Sender: TObject);
|
||||
procedure btnCheckClick(Sender: TObject);
|
||||
procedure btnProviderCheckClick(Sender: TObject);
|
||||
procedure btnValSumClick(Sender: TObject);
|
||||
procedure reResultsEnter(Sender: TObject);
|
||||
procedure JvCustomValidator1Validate(Sender: TObject;
|
||||
ValueToValidate: Variant; var Valid: Boolean);
|
||||
procedure JvValidators1ValidateFailed(Sender: TObject;
|
||||
BaseValidator: TJvBaseValidator; var Continue: Boolean);
|
||||
procedure JvValidationSummary1Change(Sender: TObject);
|
||||
private
|
||||
{ Private declarations }
|
||||
procedure ProviderErrorValidateFailed(Sender: TObject;
|
||||
BaseValidator: TJvBaseValidator; var Continue: Boolean);
|
||||
public
|
||||
{ Public declarations }
|
||||
end;
|
||||
|
||||
var
|
||||
frmMain: TfrmMain;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Variants;
|
||||
|
||||
{$R *.lfm}
|
||||
|
||||
procedure TfrmMain.FormCreate(Sender: TObject);
|
||||
begin
|
||||
reResults.WordWrap := true;
|
||||
JvValidators1.ErrorIndicator := JvErrorIndicator1;
|
||||
JvValidators1.ValidationSummary := JvValidationSummary1;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.btnCheckClick(Sender: TObject);
|
||||
begin
|
||||
reResults.Lines.Clear;
|
||||
reResults.WordWrap := false;
|
||||
JvErrorIndicator1.ClearErrors;
|
||||
JvValidators1.ValidationSummary := nil;
|
||||
JvValidators1.ErrorIndicator := nil;
|
||||
JvValidators1.OnValidateFailed := JvValidators1ValidateFailed;
|
||||
JvValidators1.Validate;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.btnProviderCheckClick(Sender: TObject);
|
||||
begin
|
||||
reResults.Lines.Clear;
|
||||
reResults.WordWrap := false;
|
||||
// calling BeginUpdate/EndUpdate delays the error reporting until all controls have been validated
|
||||
JvErrorIndicator1.BeginUpdate;
|
||||
try
|
||||
JvErrorIndicator1.ClearErrors;
|
||||
JvValidators1.ValidationSummary := nil;
|
||||
// custom error messages for this type of check
|
||||
JvValidators1.OnValidateFailed := ProviderErrorValidateFailed;
|
||||
JvValidators1.Validate;
|
||||
finally
|
||||
JvErrorIndicator1.EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.btnValSumClick(Sender: TObject);
|
||||
begin
|
||||
reResults.Lines.Clear;
|
||||
reResults.WordWrap := false;
|
||||
JvErrorIndicator1.ClearErrors;
|
||||
JvValidators1.OnValidateFailed := nil;
|
||||
JvValidators1.ErrorIndicator := nil;
|
||||
// Setting the ValidationSummary for TJvValidators will delay
|
||||
// triggering the OnChange event until after Validate has completed
|
||||
JvValidationSummary1.Summaries.Clear;
|
||||
JvValidators1.ValidationSummary := JvValidationSummary1;
|
||||
JvValidators1.Validate;
|
||||
end;
|
||||
|
||||
procedure TfrmMain.reResultsEnter(Sender: TObject);
|
||||
begin
|
||||
SelectNext(reResults,true,true);
|
||||
end;
|
||||
|
||||
procedure TfrmMain.JvCustomValidator1Validate(Sender: TObject;
|
||||
ValueToValidate: Variant; var Valid: Boolean);
|
||||
begin
|
||||
// custom validation
|
||||
Valid := not VarIsNull(ValueToValidate) and (Length(string(ValueToValidate)) >= 10);
|
||||
end;
|
||||
|
||||
procedure TfrmMain.JvValidators1ValidateFailed(Sender: TObject;
|
||||
BaseValidator: TJvBaseValidator; var Continue: Boolean);
|
||||
begin
|
||||
// using the OnValidateFailed event
|
||||
reResults.Lines.Add(Format('FAILED: %s',[BaseValidator.ErrorMessage]));
|
||||
end;
|
||||
|
||||
procedure TfrmMain.ProviderErrorValidateFailed(Sender: TObject;
|
||||
BaseValidator: TJvBaseValidator; var Continue: Boolean);
|
||||
begin
|
||||
JvErrorIndicator1.Error[BaseValidator.ControlToValidate] := BaseValidator.ErrorMessage;
|
||||
reResults.Lines.Add(Format('PROVIDER: %s',[BaseValidator.ErrorMessage]));
|
||||
end;
|
||||
procedure TfrmMain.JvValidationSummary1Change(Sender: TObject);
|
||||
var i:integer;
|
||||
begin
|
||||
// update all at once
|
||||
reResults.Lines.Text := TJvValidationSummary(Sender).Summaries.Text;
|
||||
for i := 0 to reResults.Lines.Count - 1 do
|
||||
reResults.Lines[i] := 'SUMMARY: ' + reResults.Lines[i];
|
||||
end;
|
||||
|
||||
end.
|
||||
@ -1,23 +1,24 @@
|
||||
<?xml version="1.0"?>
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="2">
|
||||
<Package Version="4">
|
||||
<PathDelim Value="\"/>
|
||||
<Name Value="JvXPBarLaz"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<AddToProjectUsesSection Value="True"/>
|
||||
<Author Value="Sergio Samayoa"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="5"/>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="..\resource\"/>
|
||||
<OtherUnitFiles Value="..\run\"/>
|
||||
<IncludeFiles Value="..\resource"/>
|
||||
<OtherUnitFiles Value="..\run"/>
|
||||
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
<CodeGeneration>
|
||||
<Generate Value="Faster"/>
|
||||
</CodeGeneration>
|
||||
<Other>
|
||||
<CompilerPath Value="$(CompPath)"/>
|
||||
</Other>
|
||||
<Parsing>
|
||||
<SyntaxOptions>
|
||||
<UseAnsiStrings Value="False"/>
|
||||
</SyntaxOptions>
|
||||
</Parsing>
|
||||
</CompilerOptions>
|
||||
<Description Value="JvXPBar (JVCL) conversion for Lazarus version 1.0
|
||||
"/>
|
||||
@ -42,7 +43,6 @@
|
||||
<UnitName Value="JvXPBarReg"/>
|
||||
</Item4>
|
||||
</Files>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<RequiredPkgs Count="3">
|
||||
<Item1>
|
||||
<PackageName Value="JvCoreLaz"/>
|
||||
@ -56,7 +56,7 @@
|
||||
</Item3>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)\"/>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
|
||||
59
components/jvcllaz/packages/jvhtcontrolslaz.lpk
Normal file
59
components/jvcllaz/packages/jvhtcontrolslaz.lpk
Normal file
@ -0,0 +1,59 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="4">
|
||||
<PathDelim Value="\"/>
|
||||
<Name Value="jvhtcontrolslaz"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<OtherUnitFiles Value="..\run;..\design"/>
|
||||
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Files Count="5">
|
||||
<Item1>
|
||||
<Filename Value="..\run\JvHtControls.pas"/>
|
||||
<UnitName Value="JvHtControls"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="..\run\JvDBHTLabel.pas"/>
|
||||
<UnitName Value="JvDBHTLabel"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="..\run\JvHint.pas"/>
|
||||
<UnitName Value="JvHint"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<Filename Value="jvhtcontrolsreg.pas"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<UnitName Value="jvhtcontrolsreg"/>
|
||||
</Item4>
|
||||
<Item5>
|
||||
<Filename Value="..\design\JvHTHintForm.pas"/>
|
||||
<UnitName Value="JvHTHintForm"/>
|
||||
</Item5>
|
||||
</Files>
|
||||
<RequiredPkgs Count="3">
|
||||
<Item1>
|
||||
<PackageName Value="IDEIntf"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="JvCoreLaz"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item3>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<CustomOptions Items="ExternHelp" Version="2">
|
||||
<_ExternHelp Items="Count"/>
|
||||
</CustomOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
24
components/jvcllaz/packages/jvhtcontrolsreg.pas
Normal file
24
components/jvcllaz/packages/jvhtcontrolsreg.pas
Normal file
@ -0,0 +1,24 @@
|
||||
unit jvhtcontrolsreg;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
{$R ../resource/JvHTControlsReg.res}
|
||||
|
||||
uses
|
||||
Classes, JvHtControls, JvDBHTLabel, JvHint, JvHTHintForm, PropEdits, Controls;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('JvHTControls', [TJvHTLabel, TJvHTComboBox, TJvHTListBox,
|
||||
TJvDBHTLabel, TJvHint]);
|
||||
RegisterPropertyEditor(TypeInfo(TCaption), TJvHTLabel, 'Caption', TJvHintProperty);
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
57
components/jvcllaz/packages/jvvalidatorlaz.lpk
Normal file
57
components/jvcllaz/packages/jvvalidatorlaz.lpk
Normal file
@ -0,0 +1,57 @@
|
||||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<CONFIG>
|
||||
<Package Version="4">
|
||||
<PathDelim Value="\"/>
|
||||
<Name Value="JvValidatorLaz"/>
|
||||
<Type Value="RunAndDesignTime"/>
|
||||
<CompilerOptions>
|
||||
<Version Value="11"/>
|
||||
<PathDelim Value="\"/>
|
||||
<SearchPaths>
|
||||
<IncludeFiles Value="..\resource"/>
|
||||
<OtherUnitFiles Value="..\run;..\design"/>
|
||||
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)"/>
|
||||
</SearchPaths>
|
||||
</CompilerOptions>
|
||||
<Files Count="4">
|
||||
<Item1>
|
||||
<Filename Value="..\run\JvErrorIndicator.pas"/>
|
||||
<UnitName Value="JvErrorIndicator"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<Filename Value="..\run\JvValidators.pas"/>
|
||||
<UnitName Value="JvValidators"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<Filename Value="jvvalidatorreg.pp"/>
|
||||
<HasRegisterProc Value="True"/>
|
||||
<AddToUsesPkgSection Value="False"/>
|
||||
<UnitName Value="JvValidatorReg"/>
|
||||
</Item3>
|
||||
<Item4>
|
||||
<Filename Value="..\design\JvValidatorsEditorForm.pas"/>
|
||||
<UnitName Value="JvValidatorsEditorForm"/>
|
||||
</Item4>
|
||||
</Files>
|
||||
<RequiredPkgs Count="3">
|
||||
<Item1>
|
||||
<PackageName Value="IDEIntf"/>
|
||||
</Item1>
|
||||
<Item2>
|
||||
<PackageName Value="JvCoreLaz"/>
|
||||
</Item2>
|
||||
<Item3>
|
||||
<PackageName Value="FCL"/>
|
||||
</Item3>
|
||||
</RequiredPkgs>
|
||||
<UsageOptions>
|
||||
<UnitPath Value="$(PkgOutDir)"/>
|
||||
</UsageOptions>
|
||||
<PublishOptions>
|
||||
<Version Value="2"/>
|
||||
</PublishOptions>
|
||||
<CustomOptions Items="ExternHelp" Version="2">
|
||||
<_ExternHelp Items="Count"/>
|
||||
</CustomOptions>
|
||||
</Package>
|
||||
</CONFIG>
|
||||
36
components/jvcllaz/packages/jvvalidatorreg.pp
Normal file
36
components/jvcllaz/packages/jvvalidatorreg.pp
Normal file
@ -0,0 +1,36 @@
|
||||
unit JvValidatorReg;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, LResources, SysUtils, ComponentEditors, PropEdits, ImageListEditor,
|
||||
GraphPropEdits;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
{$R ..\resource\JvValidatorsReg.res}
|
||||
|
||||
uses JvValidators, JvErrorIndicator, JvValidatorsEditorForm;
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
RegisterComponents('JvValidators', [TJvValidators, TJvValidationSummary, TJvErrorIndicator]);
|
||||
RegisterNoIcon([TJvRequiredFieldValidator, TJvCompareValidator,
|
||||
TJvRangeValidator, TJvRegularExpressionValidator, TJvCustomValidator, TJvControlsCompareValidator]);
|
||||
|
||||
RegisterComponentEditor(TJvValidators, TJvValidatorEditor);
|
||||
RegisterPropertyEditor(TypeInfo(Integer), TJvErrorIndicator, 'ImageIndex', TImageIndexPropertyEditor);
|
||||
// RegisterPropertyEditor(TypeInfo(string), TJvCustomFormatEdit, 'Characters', TJvCharStringProperty);
|
||||
RegisterPropertyEditor(TypeInfo(string), TJvBaseValidator, 'PropertyToValidate', TJvPropertyValidateProperty);
|
||||
RegisterPropertyEditor(TypeInfo(string), TJvBaseValidator, 'CompareToProperty', TJvPropertyToCompareProperty); end;
|
||||
|
||||
(*
|
||||
initialization
|
||||
{$I JvXPBarLaz.lrs}
|
||||
*)
|
||||
|
||||
end.
|
||||
268
components/jvcllaz/run/JvDBHTLabel.pas
Normal file
268
components/jvcllaz/run/JvDBHTLabel.pas
Normal file
@ -0,0 +1,268 @@
|
||||
{-----------------------------------------------------------------------------
|
||||
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/MPL-1.1.html
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
||||
the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is: JvDBHTLabel.PAS, released on 2004-02-01.
|
||||
|
||||
The Initial Developers of the Original Code are: Maciej Kaczkowski
|
||||
Copyright (c) 2003 Maciej Kaczkowski
|
||||
All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
|
||||
You may retrieve the latest version of this file at the Project JEDI's
|
||||
JVCL home page, located at http://jvcl.delphi-jedi.org
|
||||
|
||||
Known Issues:
|
||||
- To display data from a datasource, use the <FIELD="fieldname"> tag in Mask.
|
||||
- You can have more than one FIELD tag in a label, i.e:
|
||||
<b>Name:</b><i><FIELD="contact"></i>, <b>Company:</b><i><FIELD="Company"></i>
|
||||
- The fieldname *must* be double-quoted!
|
||||
-----------------------------------------------------------------------------}
|
||||
// $Id$
|
||||
|
||||
unit JvDBHTLabel;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
//{.$I jvcl.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, LMessages, DB, DBCtrls, Controls, JvHtControls;
|
||||
|
||||
type
|
||||
TJvDBHTLabel = class(TJvCustomHTLabel)
|
||||
private
|
||||
FDataLink: TFieldDataLink;
|
||||
FMask: string;
|
||||
function GetDataSource: TDataSource;
|
||||
procedure SetDataSource(const Value: TDataSource);
|
||||
procedure DataChange(Sender: TObject);
|
||||
procedure SetMask(const Value: string);
|
||||
procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK;
|
||||
protected
|
||||
function GetLabelText: string; override;
|
||||
procedure Loaded; override;
|
||||
procedure Notification(AComponent: TComponent;
|
||||
Operation: TOperation); override;
|
||||
//procedure SetAutoSize(Value: Boolean); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure UpdateCaption;
|
||||
published
|
||||
property DataSource: TDataSource read GetDataSource write SetDataSource;
|
||||
property Mask: string read FMask write SetMask;
|
||||
|
||||
property Align;
|
||||
property AutoSize;
|
||||
property Constraints;
|
||||
property Color;
|
||||
property Layout;
|
||||
property DragCursor;
|
||||
property BiDiMode;
|
||||
property DragKind;
|
||||
property ParentBiDiMode;
|
||||
property OnEndDock;
|
||||
property OnStartDock;
|
||||
property DragMode;
|
||||
property Enabled;
|
||||
property FocusControl;
|
||||
property Font;
|
||||
property ParentColor;
|
||||
property ParentFont;
|
||||
property ParentShowHint;
|
||||
property PopupMenu;
|
||||
property ShowHint;
|
||||
property Transparent;
|
||||
property Visible;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnDragDrop;
|
||||
property OnDragOver;
|
||||
property OnEndDrag;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnStartDrag;
|
||||
property OnHyperLinkClick;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
SysUtils{, dbconst};
|
||||
|
||||
function ReplaceFieldNameTag(Str: string; DataSet: TDataSet): string;
|
||||
var
|
||||
F: TField;
|
||||
const
|
||||
FieldName = 'FIELD'; // non-standard html
|
||||
// FieldStr = '<' + FieldName + '=';
|
||||
FieldLabelName = 'FIELDLABEL';
|
||||
// FieldLabelStr = '<' + FieldLabelName + '=';
|
||||
|
||||
function ExtractPropertyValue(Tag, PropName: string): string;
|
||||
begin
|
||||
Result := '';
|
||||
PropName := UpperCase(PropName);
|
||||
if Pos(PropName, UpperCase(Tag)) > 0 then
|
||||
begin
|
||||
Result := Copy(Tag, Pos(PropName, UpperCase(Tag))+Length(PropName), Length(Tag));
|
||||
Result := Copy(Result, Pos('"', Result)+1, Length(Result));
|
||||
Result := Copy(Result, 1, Pos('"', Result)-1);
|
||||
end;
|
||||
end;
|
||||
|
||||
function ExtractProperty(AStr: string; const PropName: string): string;
|
||||
var
|
||||
J: Integer;
|
||||
I: Integer;
|
||||
A, FieldName, Text: string;
|
||||
PropStr: string;
|
||||
begin
|
||||
Result := '';
|
||||
PropStr := '<'+PropName+'=';
|
||||
I := Pos(PropStr, UpperCase(AStr));
|
||||
while I > 0 do
|
||||
begin
|
||||
Result := Result + Copy(AStr, 1, I - 1);
|
||||
A := Copy(AStr, I, Length(AStr));
|
||||
J := Pos('>', A);
|
||||
if J > 0 then
|
||||
Delete(AStr, 1, I + J - 1)
|
||||
else
|
||||
AStr := '';
|
||||
FieldName := ExtractPropertyValue(A, PropStr);
|
||||
if Assigned(DataSet) and DataSet.Active then
|
||||
begin
|
||||
F := DataSet.FindField(FieldName);
|
||||
if F <> nil then
|
||||
begin
|
||||
if PropName = FieldLabelName then
|
||||
Text := F.DisplayLabel
|
||||
else
|
||||
Text := F.DisplayText;
|
||||
end
|
||||
else
|
||||
Text := Format('(%s)', [FieldName]);
|
||||
end
|
||||
else
|
||||
Text := Format('(%s)', [FieldName]);
|
||||
Result := Result + Text;
|
||||
I := Pos(PropStr, UpperCase(AStr));
|
||||
end;
|
||||
Result := Result + AStr;
|
||||
end;
|
||||
|
||||
begin
|
||||
Result := ExtractProperty(Str, FieldLabelName);
|
||||
Result := ExtractProperty(Result, FieldName);
|
||||
end;
|
||||
|
||||
//=== { TJvDBHTLabel } =======================================================
|
||||
|
||||
procedure TJvDBHTLabel.CMGetDataLink(var Message: TLMessage);
|
||||
begin
|
||||
Message.Result := PtrInt(FDataLink);
|
||||
end;
|
||||
|
||||
constructor TJvDBHTLabel.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FDataLink := TFieldDataLink.Create;
|
||||
with FDataLink do
|
||||
begin
|
||||
Control := Self;
|
||||
OnDataChange := @DataChange;
|
||||
OnEditingChange := @DataChange;
|
||||
OnUpdateData := @DataChange;
|
||||
OnActiveChange := @DataChange;
|
||||
end;
|
||||
end;
|
||||
|
||||
destructor TJvDBHTLabel.Destroy;
|
||||
begin
|
||||
FreeAndNil(FDataLink);
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TJvDBHTLabel.UpdateCaption;
|
||||
begin
|
||||
if Assigned(FDataLink) and Assigned(FDataLink.DataSet) then
|
||||
Caption := ReplaceFieldNameTag(FMask, FDataLink.DataSet)
|
||||
else
|
||||
Caption := ReplaceFieldNameTag(Mask, nil);
|
||||
end;
|
||||
|
||||
function TJvDBHTLabel.GetDataSource: TDataSource;
|
||||
begin
|
||||
Result := FDataLink.DataSource;
|
||||
end;
|
||||
|
||||
function TJvDBHTLabel.GetLabelText: string;
|
||||
begin
|
||||
if csPaintCopy in ControlState then
|
||||
begin
|
||||
if (Assigned(FDataLink) and Assigned(FDataLink.DataSet)) then
|
||||
Result := ReplaceFieldNameTag(FMask, FDataLink.DataSet)
|
||||
else
|
||||
Result := ReplaceFieldNameTag(Mask, nil);
|
||||
end
|
||||
else
|
||||
Result := Caption;
|
||||
end;
|
||||
|
||||
procedure TJvDBHTLabel.Loaded;
|
||||
begin
|
||||
inherited;
|
||||
if (csDesigning in ComponentState) then DataChange(Self);
|
||||
end;
|
||||
|
||||
procedure TJvDBHTLabel.Notification(AComponent: TComponent; Operation: TOperation);
|
||||
begin
|
||||
inherited;
|
||||
if (Operation = opRemove) and (FDataLink <> nil) and
|
||||
(AComponent = DataSource) then
|
||||
DataSource := nil;
|
||||
end;
|
||||
|
||||
//procedure TJvDBHTLabel.SetAutoSize(Value: Boolean);
|
||||
//begin
|
||||
// if AutoSize <> Value then
|
||||
// begin
|
||||
// if Value and FDataLink.DataSourceFixed then DatabaseError('SDataSourceFixed');
|
||||
// inherited;
|
||||
// end;
|
||||
//end;
|
||||
|
||||
procedure TJvDBHTLabel.SetDataSource(const Value: TDataSource);
|
||||
begin
|
||||
FDataLink.DataSource := Value;
|
||||
UpdateCaption;
|
||||
end;
|
||||
|
||||
procedure TJvDBHTLabel.DataChange(Sender: TObject);
|
||||
begin
|
||||
UpdateCaption;
|
||||
end;
|
||||
|
||||
procedure TJvDBHTLabel.SetMask(const Value: string);
|
||||
begin
|
||||
if FMask <> Value then
|
||||
begin
|
||||
FMask := Value;
|
||||
UpdateCaption;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
|
||||
878
components/jvcllaz/run/JvErrorIndicator.pas
Normal file
878
components/jvcllaz/run/JvErrorIndicator.pas
Normal file
@ -0,0 +1,878 @@
|
||||
{-----------------------------------------------------------------------------
|
||||
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/MPL-1.1.html
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
||||
the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is: JvErrorIndicator.pas, released on 2002-11-16.
|
||||
|
||||
The Initial Developer of the Original Code is Peter Thörnqvist <peter3 at sourceforge dot net>.
|
||||
Portions created by Peter Thörnqvist are Copyright (C) 2002 Peter Thörnqvist .
|
||||
All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
|
||||
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
||||
located at http://jvcl.delphi-jedi.org
|
||||
|
||||
Known Issues:
|
||||
* Setting AutoScroll to True for a form and displaying error icons beyond the form's right
|
||||
edge can make the form's scrollbars "jump up and down"
|
||||
* Resizing components while displaying error images, doesn't move the error image smoothly
|
||||
(this is caused by the image being moved only when the BlinkThread triggers)
|
||||
|
||||
Description:
|
||||
A component patterned on the ErrorProvider in .NET:
|
||||
"Provides a user interface for indicating that a control
|
||||
on a form has an error associated with it."
|
||||
To set the error, use the Error property: an empty error string, removes the error image
|
||||
|
||||
-----------------------------------------------------------------------------}
|
||||
// $Id$
|
||||
|
||||
unit JvErrorIndicator;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, Graphics, Controls, ImgList;
|
||||
|
||||
type
|
||||
IJvErrorIndicatorClient = interface;
|
||||
|
||||
// IJvErrorIndicator is implemented by the TJvErrorIndicator
|
||||
IJvErrorIndicator = interface
|
||||
['{5BCB5404-9C17-4CC6-96EC-46567CA19A12}']
|
||||
procedure BeginUpdate;
|
||||
procedure EndUpdate;
|
||||
procedure SetError(AControl: TControl; const AErrorMessage: WideString);
|
||||
procedure SetClientError(const AClient: IJvErrorIndicatorClient);
|
||||
end;
|
||||
|
||||
// IJvErrorIndicatorClient should be implemented by controls that wants to be able
|
||||
// to update the error indicator through it's own properties
|
||||
IJvErrorIndicatorClient = interface
|
||||
['{9871F250-631E-4119-B073-71B28711C9B8}']
|
||||
procedure SetErrorIndicator(const Value: IJvErrorIndicator);
|
||||
function GetErrorIndicator: IJvErrorIndicator;
|
||||
function GetControl: TControl;
|
||||
procedure SetErrorMessage(const Value: WideString);
|
||||
function GetErrorMessage: WideString;
|
||||
|
||||
property ErrorIndicator: IJvErrorIndicator read GetErrorIndicator write SetErrorIndicator;
|
||||
property ErrorMessage: WideString read GetErrorMessage write SetErrorMessage;
|
||||
end;
|
||||
|
||||
TJvErrorBlinkStyle = (ebsAlwaysBlink, ebsBlinkIfDifferentError, ebsNeverBlink);
|
||||
TJvErrorImageAlignment = (eiaBottomLeft, eiaBottomRight, eiaMiddleLeft, eiaMiddleRight,
|
||||
eiaTopLeft, eiaTopRight);
|
||||
|
||||
{ TJvErrorControl }
|
||||
|
||||
TJvErrorControl = class(TGraphicControl)
|
||||
private
|
||||
FImageList: TCustomImageList;
|
||||
FImageIndex: Integer;
|
||||
FImagePadding: Integer;
|
||||
FControl: TControl;
|
||||
FImageAlignment: TJvErrorImageAlignment;
|
||||
FBlinkCount: Integer;
|
||||
FUseAnchors: Boolean;
|
||||
procedure SetError(const Value: string);
|
||||
function GetError: string;
|
||||
procedure SetImageIndex(const Value: Integer);
|
||||
procedure SetImageList(const Value: TCustomImageList);
|
||||
procedure SetControl(const Value: TControl);
|
||||
procedure SetUseAnchors(AValue: Boolean);
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
procedure UpdateAnchors;
|
||||
public
|
||||
function CalcBoundsRect: TRect;
|
||||
property Images: TCustomImageList read FImageList write SetImageList;
|
||||
property ImageIndex: Integer read FImageIndex write SetImageIndex;
|
||||
property Control: TControl read FControl write SetControl;
|
||||
property Error: string read GetError write SetError;
|
||||
property BlinkCount: Integer read FBlinkCount write FBlinkCount;
|
||||
property ImageAlignment: TJvErrorImageAlignment read FImageAlignment write FImageAlignment;
|
||||
property ImagePadding: Integer read FImagePadding write FImagePadding;
|
||||
property UseAnchors: Boolean read FUseAnchors write SetUseAnchors;
|
||||
|
||||
procedure DrawImage(Erase: Boolean);
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
property ShowHint default True;
|
||||
property Width default 16;
|
||||
property Height default 16;
|
||||
end;
|
||||
|
||||
{ TJvErrorIndicator }
|
||||
|
||||
TJvErrorIndicator = class(TComponent, IUnknown, IJvErrorIndicator)
|
||||
private
|
||||
FDefaultUseAnchors: Boolean;
|
||||
FUpdateCount: Integer;
|
||||
FControls: TList;
|
||||
FBlinkRate: Integer;
|
||||
FImageList: TCustomImageList;
|
||||
FBlinkThread: TThread;
|
||||
FBlinkStyle: TJvErrorBlinkStyle;
|
||||
FChangeLink: TChangeLink;
|
||||
FImageIndex: Integer;
|
||||
FDefaultImage: TImageList;
|
||||
function GetError(AControl: TControl): string;
|
||||
function GetImageAlignment(AControl: TControl): TJvErrorImageAlignment;
|
||||
function GetImagePadding(AControl: TControl): Integer;
|
||||
function GetUseAnchors(AControl: TControl): Boolean;
|
||||
procedure SetBlinkRate(const Value: Integer);
|
||||
procedure SetBlinkStyle(const Value: TJvErrorBlinkStyle);
|
||||
procedure SetError(AControl: TControl; const Value: string);
|
||||
procedure SetImageList(const Value: TCustomImageList);
|
||||
procedure SetImageAlignment(AControl: TControl; const Value: TJvErrorImageAlignment);
|
||||
procedure SetImagePadding(AControl: TControl; const Value: Integer);
|
||||
procedure SetImageIndex(const Value: Integer);
|
||||
procedure DoChangeLinkChange(Sender: TObject);
|
||||
procedure DoBlink(Sender: TObject; Erase: Boolean);
|
||||
procedure SetUseAnchors(AControl: TControl; AValue: Boolean);
|
||||
procedure StopThread;
|
||||
procedure StartThread;
|
||||
function GetControl(Index: Integer): TJvErrorControl;
|
||||
function GetCount: Integer;
|
||||
protected
|
||||
{ IJvErrorIndicator }
|
||||
procedure IJvErrorIndicator.SetError = IndicatorSetError;
|
||||
procedure IndicatorSetError(AControl: TControl; const ErrorMessage: WideString);
|
||||
procedure SetClientError(const AClient: IJvErrorIndicatorClient);
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
function IndexOf(AControl: TControl): Integer;
|
||||
function Add(AControl: TControl): Integer;
|
||||
procedure UpdateControls;
|
||||
procedure Delete(Index: Integer);
|
||||
property Controls[Index: Integer]: TJvErrorControl read GetControl;
|
||||
property Count: Integer read GetCount;
|
||||
public
|
||||
constructor Create(AComponent: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
// Call ClearErrors to remove all error images with one call
|
||||
// After a call to ClearErrors, the internal error image list is emptied
|
||||
// Calling ClearErrors is the same as setting Error[nil] := '' but is slightly faster
|
||||
procedure ClearErrors;
|
||||
// The BeginUpdate method suspends the blinking thread until the EndUpdate method is called.
|
||||
procedure BeginUpdate;
|
||||
// EndUpdate re-enables the blinking thread that was turned off with the BeginUpdate method.
|
||||
procedure EndUpdate;
|
||||
// Gets or sets the error message associated with a control
|
||||
// Setting the error message to an empty string removes the error image
|
||||
// (this is the only way to remove an error image for a single control)
|
||||
// Use Error[nil] := 'SomeValue'; to assign the error message 'SomeValue' to all controls
|
||||
// Using Error[nil] := ''; is equivalent to calling ClearErrors but ClearErrors is faster
|
||||
property Error[AControl: TControl]: string read GetError write SetError;
|
||||
// Gets or sets a value indicating where the error image should be placed in relation to the control.
|
||||
// The location can be further modified by assigning a non-zero value to ImagePadding
|
||||
// Possible values:
|
||||
// eiaBottomLeft - display the error image on the controls left side aligned to the bottom edge of the control
|
||||
// eiaBottomRight - display the error image on the controls right side aligned to the bottom edge of the control
|
||||
// eiaMiddleLeft - display the error image on the controls left side aligned to the middle of the control
|
||||
// eiaMiddleRight - display the error image on the controls right side aligned to the middle of the control
|
||||
// eiaTopLeft - display the error image on the controlsleft side aligned to the top edge of the control
|
||||
// eiaTopRight - display the error image on the controls right side aligned to the top edge of the control
|
||||
// Use AControl = nil to set the same Alignment for all controls
|
||||
property ImageAlignment[AControl: TControl]: TJvErrorImageAlignment read GetImageAlignment write SetImageAlignment;
|
||||
// Gets or sets the amount of extra space to leave between the specified control and the error image.
|
||||
// Use AControl = nil to set the same padding for all controls.
|
||||
property ImagePadding[AControl: TControl]: Integer read GetImagePadding write SetImagePadding;
|
||||
//
|
||||
property UseAnchors[AControl: TControl]: Boolean read GetUseAnchors write SetUseAnchors;
|
||||
published
|
||||
// The rate at which the error image should flash. The rate is expressed in milliseconds. The default is 250 milliseconds.
|
||||
// A value of zero sets BlinkStyle to ebsNeverBlink.
|
||||
property BlinkRate: Integer read FBlinkRate write SetBlinkRate default 250;
|
||||
// The error Image flashes in the manner specified by the assigned BlinkStyle when an error occurs.
|
||||
// Possible values:
|
||||
// ebsBlinkIfDifferentError - blink if the new error message differs from the previous
|
||||
// ebsAlwaysBlink - always blink when the error message changes, even if it's the same message
|
||||
// ebsNeverBlink - never bink, just display the error image and the description
|
||||
// Setting the BlinkRate to zero sets the BlinkStyle to ebsNeverBlink.
|
||||
// The default is ebsBlinkIfDifferentError
|
||||
property BlinkStyle: TJvErrorBlinkStyle read FBlinkStyle write SetBlinkStyle default ebsBlinkIfDifferentError;
|
||||
// Gets or sets the ImageList where to retrieve an image to display next to a control when an error description
|
||||
// string has been set for the control.
|
||||
// This property is used in conjunction with ImageIndex to select the image to display
|
||||
// If either is nil, invalid or out of range, no error image is displayed
|
||||
property Images: TCustomImageList read FImageList write SetImageList;
|
||||
// Gets or sets the ImageIndex in ImageList to use when displaying an image next to a control
|
||||
property ImageIndex: Integer read FImageIndex write SetImageIndex;
|
||||
property DefaultUseAnchors: Boolean read FDefaultUseAnchors write FDefaultUseAnchors;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
//CommCtrl,
|
||||
LCLProc,
|
||||
SysUtils,
|
||||
JvResources, JvJVCLUtils;
|
||||
|
||||
{$R ..\resource\JvErrorIndicator.res}
|
||||
|
||||
const
|
||||
cDefBlinkCount = 5;
|
||||
|
||||
type
|
||||
TJvBlinkThreadEvent = procedure(Sender: TObject; Erase: Boolean) of object;
|
||||
|
||||
TJvBlinkThread = class(TThread)
|
||||
private
|
||||
FBlinkRate: Integer;
|
||||
FErase: Boolean;
|
||||
FOnBlink: TJvBlinkThreadEvent;
|
||||
procedure Blink;
|
||||
protected
|
||||
procedure Execute; override;
|
||||
public
|
||||
constructor Create(BlinkRate: Integer; AOnBlink: TJvBlinkThreadEvent);
|
||||
end;
|
||||
|
||||
//=== { TJvErrorIndicator } ==================================================
|
||||
|
||||
constructor TJvErrorIndicator.Create(AComponent: TComponent);
|
||||
|
||||
begin
|
||||
inherited Create(AComponent);
|
||||
FDefaultImage := TImageList.CreateSize(16, 16);
|
||||
FDefaultImage.AddResourceName(HINSTANCE, 'XJVERRORINDICATORICON');
|
||||
//ImageList_AddIcon(FDefaultImage.Handle,
|
||||
// LoadImage(HInstance, PChar('XJVERRORINDICATORICON'), IMAGE_ICON, 16, 16, 0));
|
||||
FBlinkStyle := ebsBlinkIfDifferentError;
|
||||
FBlinkRate := 250;
|
||||
FControls := TList.Create;
|
||||
FChangeLink := TChangeLink.Create;
|
||||
FChangeLink.OnChange := @DoChangeLinkChange;
|
||||
end;
|
||||
|
||||
destructor TJvErrorIndicator.Destroy;
|
||||
begin
|
||||
StopThread;
|
||||
ClearErrors;
|
||||
FControls.Free;
|
||||
FChangeLink.Free;
|
||||
FDefaultImage.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.Add(AControl: TControl): Integer;
|
||||
var
|
||||
Ci: TJvErrorControl;
|
||||
begin
|
||||
Result := IndexOf(AControl);
|
||||
if (Result < 0) and (AControl <> nil) then
|
||||
begin
|
||||
Ci := TJvErrorControl.Create(Self);
|
||||
Ci.Control := AControl;
|
||||
Ci.UseAnchors := DefaultUseAnchors;
|
||||
// Ci.Name := Ci.Control.Name + '_ErrorControl';
|
||||
Result := FControls.Add(Ci);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.Delete(Index: Integer);
|
||||
begin
|
||||
Controls[Index].Free; // removes itself from FControls[]
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.GetError(AControl: TControl): string;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
I := IndexOf(AControl);
|
||||
if I > -1 then
|
||||
Result := Controls[I].Error
|
||||
else
|
||||
raise Exception.Create(RsEControlNotFoundInGetError);
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.GetImageAlignment(AControl: TControl): TJvErrorImageAlignment;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
I := IndexOf(AControl);
|
||||
if I > -1 then
|
||||
Result := Controls[I].ImageAlignment
|
||||
else
|
||||
raise Exception.Create(RsEControlNotFoundInGetImageAlignment);
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.GetImagePadding(AControl: TControl): Integer;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
I := IndexOf(AControl);
|
||||
if I > -1 then
|
||||
Result := Controls[I].ImagePadding
|
||||
else
|
||||
raise Exception.Create(RsEControlNotFoundInGetImagePadding);
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.GetUseAnchors(AControl: TControl): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
I := IndexOf(AControl);
|
||||
if I > -1 then
|
||||
Result := Controls[I].UseAnchors
|
||||
else
|
||||
raise Exception.Create(RsEControlNotFoundInGetUseAnhors);
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.IndexOf(AControl: TControl): Integer;
|
||||
begin
|
||||
if AControl <> nil then
|
||||
for Result := 0 to Count - 1 do
|
||||
if Controls[Result].Control = AControl then
|
||||
Exit;
|
||||
Result := -1;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if Operation = opRemove then
|
||||
begin
|
||||
if AComponent is TControl then
|
||||
I := IndexOf(TControl(AComponent))
|
||||
else
|
||||
I := -1;
|
||||
if I > -1 then
|
||||
Delete(I);
|
||||
if AComponent = Images then
|
||||
Images := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetBlinkRate(const Value: Integer);
|
||||
begin
|
||||
if FBlinkRate <> Value then
|
||||
begin
|
||||
StopThread;
|
||||
FBlinkRate := Value;
|
||||
if FBlinkRate <= 0 then
|
||||
begin
|
||||
FBlinkRate := 0;
|
||||
FBlinkStyle := ebsNeverBlink;
|
||||
end;
|
||||
UpdateControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetBlinkStyle(const Value: TJvErrorBlinkStyle);
|
||||
begin
|
||||
if FBlinkStyle <> Value then
|
||||
begin
|
||||
StopThread;
|
||||
FBlinkStyle := Value;
|
||||
UpdateControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetError(AControl: TControl;
|
||||
const Value: string);
|
||||
var
|
||||
I: Integer;
|
||||
Ei: TJvErrorControl;
|
||||
begin
|
||||
StopThread;
|
||||
if AControl = nil then
|
||||
begin
|
||||
if Value = '' then
|
||||
ClearErrors
|
||||
else
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
Ei := Controls[I];
|
||||
if ((Ei.Error <> Value) and (BlinkStyle = ebsBlinkIfDifferentError)) or (BlinkStyle = ebsAlwaysBlink) then
|
||||
Ei.BlinkCount := cDefBlinkCount
|
||||
else
|
||||
if BlinkStyle = ebsNeverBlink then
|
||||
Ei.BlinkCount := 0;
|
||||
Ei.Error := Value;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
I := Add(AControl);
|
||||
if I > -1 then
|
||||
begin
|
||||
if Value = '' then
|
||||
Delete(I)
|
||||
else
|
||||
begin
|
||||
Ei := Controls[I];
|
||||
if ((Ei.Error <> Value) and (BlinkStyle = ebsBlinkIfDifferentError)) or
|
||||
(BlinkStyle = ebsAlwaysBlink) then
|
||||
begin
|
||||
Ei.Error := Value;
|
||||
Ei.BlinkCount := cDefBlinkCount;
|
||||
Ei.Visible := (csDesigning in ComponentState);
|
||||
if (FUpdateCount = 0) and (FBlinkThread = nil) then
|
||||
StartThread;
|
||||
end
|
||||
else
|
||||
if BlinkStyle = ebsNeverBlink then
|
||||
begin
|
||||
Ei.BlinkCount := 0;
|
||||
Ei.Error := Value;
|
||||
Ei.Visible := (Value <> '');
|
||||
end;
|
||||
end;
|
||||
UpdateControls;
|
||||
end
|
||||
else
|
||||
raise Exception.Create(RsEUnableToAddControlInSetError);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetImageAlignment(AControl: TControl;
|
||||
const Value: TJvErrorImageAlignment);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if AControl = nil then
|
||||
for I := 0 to Count - 1 do
|
||||
Controls[I].ImageAlignment := Value
|
||||
else
|
||||
begin
|
||||
I := Add(AControl);
|
||||
if I > -1 then
|
||||
Controls[I].ImageAlignment := Value
|
||||
else
|
||||
raise Exception.Create(RsEUnableToAddControlInSetImageAlignme);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetImagePadding(AControl: TControl;
|
||||
const Value: Integer);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if AControl = nil then
|
||||
for I := 0 to Count - 1 do
|
||||
Controls[I].ImagePadding := Value
|
||||
else
|
||||
begin
|
||||
I := Add(AControl);
|
||||
if I > -1 then
|
||||
Controls[I].ImagePadding := Value
|
||||
else
|
||||
raise Exception.Create(RsEUnableToAddControlInSetImagePadding);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.UpdateControls;
|
||||
var
|
||||
I, J: Integer;
|
||||
IL: TCustomImageList;
|
||||
begin
|
||||
if Images <> nil then
|
||||
begin
|
||||
IL := Images;
|
||||
J := ImageIndex;
|
||||
end
|
||||
else
|
||||
begin
|
||||
IL := FDefaultImage;
|
||||
J := 0;
|
||||
end;
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
Controls[I].Images := IL;
|
||||
Controls[I].ImageIndex := J;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetImageList(const Value: TCustomImageList);
|
||||
begin
|
||||
if FImageList <> Value then
|
||||
begin
|
||||
StopThread;
|
||||
ReplaceImageListReference(Self, Value, FImageList, FChangeLink);
|
||||
UpdateControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetImageIndex(const Value: Integer);
|
||||
begin
|
||||
if FImageIndex <> Value then
|
||||
begin
|
||||
StopThread;
|
||||
FImageIndex := Value;
|
||||
UpdateControls;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.DoChangeLinkChange(Sender: TObject);
|
||||
begin
|
||||
UpdateControls;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.ClearErrors;
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
StopThread;
|
||||
for I := Count - 1 downto 0 do
|
||||
Controls[I].Free;
|
||||
FControls.Clear;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.BeginUpdate;
|
||||
{var
|
||||
I: Integer;}
|
||||
begin
|
||||
Inc(FUpdateCount);
|
||||
StopThread;
|
||||
// ahuser: The following code produces flicker
|
||||
{for I := 0 to Count - 1 do
|
||||
Controls[I].Visible := False;}
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.EndUpdate;
|
||||
begin
|
||||
if FUpdateCount > 0 then
|
||||
begin
|
||||
Dec(FUpdateCount);
|
||||
if FUpdateCount = 0 then
|
||||
begin
|
||||
UpdateControls;
|
||||
StartThread;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.StartThread;
|
||||
begin
|
||||
if BlinkStyle <> ebsNeverBlink then
|
||||
FBlinkThread := TJvBlinkThread.Create(BlinkRate, @DoBlink);
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.StopThread;
|
||||
begin
|
||||
if FBlinkThread <> nil then
|
||||
try
|
||||
FBlinkThread.Terminate;
|
||||
FBlinkThread.WaitFor;
|
||||
finally
|
||||
FreeAndNil(FBlinkThread);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.DoBlink(Sender: TObject; Erase: Boolean);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
for I := 0 to Count - 1 do
|
||||
Controls[I].DrawImage(Erase);
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetUseAnchors(AControl: TControl; AValue: Boolean);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
if AControl = nil then
|
||||
for I := 0 to Count - 1 do
|
||||
Controls[I].UseAnchors := AValue
|
||||
else
|
||||
begin
|
||||
I := Add(AControl);
|
||||
if I > -1 then
|
||||
Controls[I].UseAnchors := AValue
|
||||
else
|
||||
raise Exception.Create(RsEUnableToAddControlInSetImagePadding);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.GetControl(Index: Integer): TJvErrorControl;
|
||||
begin
|
||||
Result := TJvErrorControl(FControls[Index]);
|
||||
end;
|
||||
|
||||
function TJvErrorIndicator.GetCount: Integer;
|
||||
begin
|
||||
Result := FControls.Count;
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.SetClientError(const AClient: IJvErrorIndicatorClient);
|
||||
begin
|
||||
if AClient <> nil then
|
||||
SetError(AClient.GetControl, UTF8Encode(AClient.ErrorMessage));
|
||||
end;
|
||||
|
||||
procedure TJvErrorIndicator.IndicatorSetError(AControl: TControl;
|
||||
const ErrorMessage: WideString);
|
||||
begin
|
||||
SetError(AControl, UTF8Encode(ErrorMessage));
|
||||
end;
|
||||
|
||||
//=== { TJvErrorControl } ====================================================
|
||||
|
||||
constructor TJvErrorControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FImageAlignment := eiaMiddleRight;
|
||||
ShowHint := True;
|
||||
Visible := False;
|
||||
Width := 16;
|
||||
Height := 16;
|
||||
end;
|
||||
|
||||
destructor TJvErrorControl.Destroy;
|
||||
begin
|
||||
TJvErrorIndicator(Owner).FControls.Extract(Self);
|
||||
Control := nil;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.DrawImage(Erase: Boolean);
|
||||
begin
|
||||
if not Assigned(Control) or not Assigned(Control.Parent) or not Assigned(Images) then
|
||||
Exit;
|
||||
Visible := (Error <> '') and (not Erase or (BlinkCount < 2));
|
||||
if not Visible and (BlinkCount > 1) then
|
||||
Dec(FBlinkCount);
|
||||
if Visible then
|
||||
if UseAnchors then
|
||||
UpdateAnchors
|
||||
else
|
||||
BoundsRect := CalcBoundsRect;
|
||||
end;
|
||||
|
||||
function TJvErrorControl.CalcBoundsRect: TRect;
|
||||
begin
|
||||
if (Control = nil) or (Images = nil) then
|
||||
Result := Rect(0, 0, 0, 0)
|
||||
else
|
||||
begin
|
||||
case ImageAlignment of
|
||||
eiaBottomLeft:
|
||||
begin
|
||||
// must qualify Result fully since Delphi confuses the TRect with the controls Top/Left properties
|
||||
Result.Right := Control.Left - 1;
|
||||
Result.Left := Result.Right - Images.Width;
|
||||
Result.Bottom := Control.Top + Control.Height;
|
||||
Result.Top := Result.Bottom - Images.Height;
|
||||
OffsetRect(Result, -ImagePadding, 0);
|
||||
end;
|
||||
eiaBottomRight:
|
||||
begin
|
||||
Result.Left := Control.Left + Control.Width + 1;
|
||||
Result.Right := Result.Left + Images.Width;
|
||||
Result.Bottom := Control.Top + Control.Height;
|
||||
Result.Top := Result.Bottom - Images.Height;
|
||||
OffsetRect(Result, ImagePadding, 0);
|
||||
end;
|
||||
eiaMiddleLeft:
|
||||
begin
|
||||
Result.Right := Control.Left - 1;
|
||||
Result.Left := Result.Right - Images.Width;
|
||||
Result.Top := Control.Top + (Control.Height - Images.Height) div 2;
|
||||
Result.Bottom := Result.Top + Images.Height;
|
||||
OffsetRect(Result, -ImagePadding, 0);
|
||||
end;
|
||||
eiaMiddleRight:
|
||||
begin
|
||||
Result.Left := Control.Left + Control.Width + 1;
|
||||
Result.Right := Result.Left + Images.Width;
|
||||
Result.Top := Control.Top + (Control.Height - Images.Height) div 2;
|
||||
Result.Bottom := Result.Top + Images.Height;
|
||||
OffsetRect(Result, ImagePadding, 0);
|
||||
end;
|
||||
eiaTopLeft:
|
||||
begin
|
||||
Result.Right := Control.Left - 1;
|
||||
Result.Left := Result.Right - Images.Width;
|
||||
Result.Top := Control.Top;
|
||||
Result.Bottom := Result.Top + Control.Height;
|
||||
OffsetRect(Result, -ImagePadding, 0);
|
||||
end;
|
||||
eiaTopRight:
|
||||
begin
|
||||
Result.Left := Control.Left + Control.Width + 1;
|
||||
Result.Right := Result.Left + Images.Width;
|
||||
Result.Top := Control.Top;
|
||||
Result.Bottom := Result.Top + Images.Height;
|
||||
OffsetRect(Result, ImagePadding, 0);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.Paint;
|
||||
begin
|
||||
// inherited Paint;
|
||||
if (Images <> nil) and Visible then
|
||||
Images.Draw(Canvas, 0, 0, ImageIndex, dsTransparent, itImage);
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.SetError(const Value: string);
|
||||
begin
|
||||
Hint := Value;
|
||||
end;
|
||||
|
||||
function TJvErrorControl.GetError: string;
|
||||
begin
|
||||
Result := Hint;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.SetImageIndex(const Value: Integer);
|
||||
begin
|
||||
if FImageIndex <> Value then
|
||||
begin
|
||||
FImageIndex := Value;
|
||||
Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.SetImageList(const Value: TCustomImageList);
|
||||
begin
|
||||
if ReplaceComponentReference(Self, Value, TComponent(FImageList)) then
|
||||
begin
|
||||
if FImageList <> nil then
|
||||
if UseAnchors then
|
||||
UpdateAnchors
|
||||
else
|
||||
BoundsRect := CalcBoundsRect
|
||||
else
|
||||
SetBounds(Left, Top, 16, 16);
|
||||
// Invalidate;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.SetControl(const Value: TControl);
|
||||
begin
|
||||
if FControl <> Value then
|
||||
begin
|
||||
ReplaceComponentReference(Self, Value, TComponent(FControl));
|
||||
if FControl <> nil then
|
||||
Parent := FControl.Parent
|
||||
else
|
||||
Parent := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.SetUseAnchors(AValue: Boolean);
|
||||
begin
|
||||
if FUseAnchors = AValue then Exit;
|
||||
FUseAnchors := AValue;
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if (Operation = opRemove) then
|
||||
if (AComponent = Control) then
|
||||
Control := nil
|
||||
else if (AComponent = FImageList) then
|
||||
FImageList := nil
|
||||
end;
|
||||
|
||||
procedure TJvErrorControl.UpdateAnchors;
|
||||
begin
|
||||
if (Control = nil) or (Images = nil) then
|
||||
begin
|
||||
SetBounds(0, 0, 0, 0);
|
||||
Exit;
|
||||
end
|
||||
else
|
||||
begin
|
||||
AnchorSide[akLeft].Control := nil;
|
||||
AnchorSide[akTop].Control := nil;
|
||||
AnchorSide[akBottom].Control := nil;
|
||||
AnchorSide[akRight].Control := nil;
|
||||
SetBounds(0, 0, Images.Width, Images.Height);
|
||||
case ImageAlignment of
|
||||
eiaBottomLeft:
|
||||
begin
|
||||
AnchorSideLeft.Control := Control;
|
||||
AnchorSideLeft.Side := asrLeft;
|
||||
AnchorSideTop.Control := Control;
|
||||
AnchorSideTop.Side := asrBottom;
|
||||
end;
|
||||
eiaBottomRight:
|
||||
begin
|
||||
AnchorSideRight.Control := Control;
|
||||
AnchorSideRight.Side := asrRight;
|
||||
AnchorSideTop.Control := Control;
|
||||
AnchorSideTop.Side := asrBottom;
|
||||
end;
|
||||
eiaMiddleLeft:
|
||||
begin
|
||||
AnchorVerticalCenterTo(Control);
|
||||
AnchorSideRight.Control := Control;
|
||||
AnchorSideRight.Side := asrLeft;
|
||||
end;
|
||||
eiaMiddleRight:
|
||||
begin
|
||||
AnchorVerticalCenterTo(Control);
|
||||
AnchorSideLeft.Control := Control;
|
||||
AnchorSideLeft.Side := asrRight;
|
||||
end;
|
||||
eiaTopLeft:
|
||||
begin
|
||||
AnchorSideLeft.Control := Control;
|
||||
AnchorSideLeft.Side := asrLeft;
|
||||
AnchorSideBottom.Control := Control;
|
||||
AnchorSideBottom.Side := asrTop;
|
||||
end;
|
||||
eiaTopRight:
|
||||
begin
|
||||
AnchorSideRight.Control := Control;
|
||||
AnchorSideRight.Side := asrRight;
|
||||
AnchorSideBottom.Control := Control;
|
||||
AnchorSideBottom.Side := asrTop;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
//=== { TJvBlinkThread } =====================================================
|
||||
|
||||
constructor TJvBlinkThread.Create(BlinkRate: Integer; AOnBlink: TJvBlinkThreadEvent);
|
||||
begin
|
||||
inherited Create(False);
|
||||
FBlinkRate := BlinkRate;
|
||||
FErase := False;
|
||||
FOnBlink := AOnBlink;
|
||||
end;
|
||||
|
||||
procedure TJvBlinkThread.Blink;
|
||||
begin
|
||||
if Assigned(FOnBlink) then
|
||||
FOnBlink(Self, FErase);
|
||||
end;
|
||||
|
||||
procedure TJvBlinkThread.Execute;
|
||||
begin
|
||||
//NameThread(ThreadName);
|
||||
FErase := False;
|
||||
while not Terminated and not Suspended do
|
||||
begin
|
||||
Sleep(FBlinkRate);
|
||||
Synchronize(@Blink);
|
||||
if FBlinkRate = 0 then
|
||||
Exit;
|
||||
FErase := not FErase;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@ -52,6 +52,13 @@ type
|
||||
dcNative); // if dcNative is in the set the native allowed keys are used and GetDlgCode is ignored
|
||||
TDlgCodes = set of TDlgCode;
|
||||
|
||||
{$IFDEF WINDOWS}
|
||||
TSmallPoint = Types.TSmallPoint;
|
||||
{$ENDIF}
|
||||
{$IFDEF LINUX}
|
||||
TSmallPoint = Classes.TSmallPoint;
|
||||
{$ENDIF}
|
||||
|
||||
(******************** NOT CONVERTED
|
||||
const
|
||||
dcWantMessage = dcWantAllKeys;
|
||||
@ -134,7 +141,8 @@ procedure HandleDotNetHighlighting(Control: TWinControl; const Msg: TLMessage;
|
||||
MouseOver: Boolean; Color: TColor);
|
||||
function CreateWMMessage(Msg: Integer; WParam: PtrInt; LParam: PtrInt): TLMessage; overload; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}
|
||||
function CreateWMMessage(Msg: Integer; WParam: PtrInt; LParam: TControl): TLMessage; overload; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}
|
||||
function SmallPointToLong(const Pt: TSmallPoint): Longint; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}
|
||||
//function SmallPointToLong(const Pt: Classes.TSmallPoint): Longint; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}
|
||||
function SmallPointToLong(const Pt: TSmallPoint): LongInt; {$IFDEF SUPPORTS_INLINE} inline {$ENDIF}
|
||||
function ShiftStateToKeyData(Shift: TShiftState): Longint;
|
||||
|
||||
//******************** NOT CONVERTED
|
||||
@ -370,7 +378,8 @@ begin
|
||||
Self.Msg.Result := 0;
|
||||
end;
|
||||
|
||||
function SmallPointToLong(const Pt: TSmallPoint): Longint;
|
||||
function SmallPointToLong(const Pt: TSmallPoint): LongInt;
|
||||
//function SmallPointToLong(const Pt: Classes.TSmallPoint): Longint;
|
||||
begin
|
||||
Result := Longint(Pt);
|
||||
end;
|
||||
|
||||
264
components/jvcllaz/run/JvHint.pas
Normal file
264
components/jvcllaz/run/JvHint.pas
Normal file
@ -0,0 +1,264 @@
|
||||
{-----------------------------------------------------------------------------
|
||||
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/MPL-1.1.html
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
||||
the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is: JvHint.PAS, released on 2002-07-04.
|
||||
|
||||
The Initial Developers of the Original Code are: Andrei Prygounkov <a dott prygounkov att gmx dott de>
|
||||
Copyright (c) 1999, 2002 Andrei Prygounkov
|
||||
All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
|
||||
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
||||
located at http://jvcl.delphi-jedi.org
|
||||
|
||||
component : TJvHint
|
||||
description : Custom activated hint
|
||||
|
||||
Known Issues:
|
||||
-----------------------------------------------------------------------------}
|
||||
// $Id$
|
||||
|
||||
unit JvHint;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
//{.$I jvcl.inc}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, Classes,
|
||||
Controls, Forms, ExtCtrls,
|
||||
JvHtControls, JvTypes;
|
||||
|
||||
type
|
||||
TJvHintWindow = class(THintWindow)
|
||||
public
|
||||
property Caption;
|
||||
end;
|
||||
TJvHintWindowClass = class of TJvHintWindow;
|
||||
|
||||
TJvHintState = (tmBeginShow, tmShowing, tmStopped);
|
||||
|
||||
TJvHint = class(TComponent)
|
||||
private
|
||||
FAutoHide: Boolean;
|
||||
protected
|
||||
// (rom) definitely needs cleanup here bad structuring
|
||||
R: TRect;
|
||||
Area: TRect;
|
||||
State: TJvHintState;
|
||||
Txt: THintString;
|
||||
HintWindow: TJvHintWindow;
|
||||
TimerHint: TTimer;
|
||||
FDelay: Integer;
|
||||
procedure TimerHintTimer(Sender: TObject);
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure ActivateHint(AArea: TRect; ATxt: THintString);
|
||||
procedure ActivateHintAt(AArea: TRect; ATxt: THintString; ScreenPos: TPoint);
|
||||
procedure CancelHint;
|
||||
published
|
||||
property AutoHide: Boolean read FAutoHide write FAutoHide default True;
|
||||
end;
|
||||
|
||||
TJvHTHintWindow = class(THintWindow)
|
||||
private
|
||||
HtLabel: TJvHTLabel;
|
||||
protected
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
function CalcHintRect({%H-}MaxWidth: Integer;
|
||||
const AHint: THintString; AData: Pointer): TRect; override;
|
||||
procedure Paint; override;
|
||||
end;
|
||||
|
||||
procedure RegisterHtHints;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Math, LCLIntf, LCLType,
|
||||
JvResources;
|
||||
|
||||
//=== { TJvHint } ============================================================
|
||||
|
||||
constructor TJvHint.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
TimerHint := TTimer.Create(Self);
|
||||
TimerHint.Enabled := False;
|
||||
TimerHint.Interval := 50;
|
||||
TimerHint.OnTimer := @TimerHintTimer;
|
||||
HintWindow := TJvHintWindowClass.Create(Self);
|
||||
ShowWindow(HintWindow.Handle, SW_HIDE);
|
||||
FAutoHide := True;
|
||||
end;
|
||||
|
||||
destructor TJvHint.Destroy;
|
||||
begin
|
||||
TimerHint.Free;
|
||||
HintWindow.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TJvHint.ActivateHint(AArea: TRect; ATxt: THintString);
|
||||
var
|
||||
P: TPoint = (X:0; y:0); // silence the compiler...
|
||||
begin
|
||||
GetCursorPos(P);
|
||||
Inc(P.Y, 20);
|
||||
ActivateHintAt(AArea, ATxt, P);
|
||||
end;
|
||||
|
||||
procedure TJvHint.ActivateHintAt(AArea: TRect; ATxt: THintString; ScreenPos: TPoint);
|
||||
var
|
||||
P: TPoint = (X: 0; Y: 0); // silence the compiler
|
||||
begin
|
||||
Area := AArea;
|
||||
if ATxt = '' then
|
||||
begin
|
||||
CancelHint;
|
||||
Exit;
|
||||
end
|
||||
else
|
||||
Txt := ATxt;
|
||||
GetCursorPos(P);
|
||||
if not PtInRect(Area, P) then
|
||||
begin
|
||||
if IsWindowVisible(HintWindow.Handle) then
|
||||
ShowWindow(HintWindow.Handle, SW_HIDE);
|
||||
Exit;
|
||||
end;
|
||||
if HintWindow.Caption <> Txt then
|
||||
begin
|
||||
R := HintWindow.CalcHintRect(Screen.Width, Txt, nil);
|
||||
R.Top := ScreenPos.Y;
|
||||
R.Left := ScreenPos.X;
|
||||
Inc(R.Bottom, R.Top);
|
||||
Inc(R.Right, R.Left);
|
||||
State := tmBeginShow;
|
||||
TimerHint.Enabled := True;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvHint.TimerHintTimer(Sender: TObject);
|
||||
var
|
||||
P: TPoint = (X: 0; Y: 0); // silence the compiler
|
||||
bPoint, bDelay: Boolean;
|
||||
Delay: Integer;
|
||||
HintPause: Integer;
|
||||
begin
|
||||
HintWindow.Color := Application.HintColor;
|
||||
Delay := FDelay * Integer(TimerHint.Interval);
|
||||
case State of
|
||||
tmBeginShow:
|
||||
begin
|
||||
GetCursorPos(P);
|
||||
bPoint := not PtInRect(Area, P);
|
||||
if bPoint then
|
||||
begin
|
||||
State := tmStopped;
|
||||
Exit;
|
||||
end;
|
||||
if IsWindowVisible(HintWindow.Handle) then
|
||||
HintPause := Application.HintShortPause
|
||||
else
|
||||
HintPause := Application.HintPause;
|
||||
if Delay >= HintPause then
|
||||
begin
|
||||
HintWindow.ActivateHint(R, Txt);
|
||||
FDelay := 0;
|
||||
State := tmShowing;
|
||||
end
|
||||
else
|
||||
Inc(FDelay);
|
||||
end;
|
||||
tmShowing:
|
||||
begin
|
||||
GetCursorPos(P);
|
||||
bDelay := FAutoHide and (Delay > Application.HintHidePause);
|
||||
bPoint := not PtInRect(Area, P);
|
||||
if bPoint or bDelay then
|
||||
begin
|
||||
if IsWindowVisible(HintWindow.Handle) then
|
||||
ShowWindow(HintWindow.Handle, SW_HIDE);
|
||||
FDelay := 0;
|
||||
if bPoint then
|
||||
HintWindow.Caption := RsHintCaption;
|
||||
State := tmStopped;
|
||||
end
|
||||
else
|
||||
Inc(FDelay);
|
||||
end;
|
||||
tmStopped:
|
||||
begin
|
||||
FDelay := 0;
|
||||
GetCursorPos(P);
|
||||
bPoint := not PtInRect(Area, P);
|
||||
if IsWindowVisible(HintWindow.Handle) then
|
||||
ShowWindow(HintWindow.Handle, SW_HIDE);
|
||||
if bPoint then
|
||||
begin
|
||||
HintWindow.Caption := RsHintCaption;
|
||||
TimerHint.Enabled := False;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvHint.CancelHint;
|
||||
begin
|
||||
if IsWindowVisible(HintWindow.Handle) then
|
||||
ShowWindow(HintWindow.Handle, SW_HIDE);
|
||||
HintWindow.Caption := '';
|
||||
end;
|
||||
|
||||
//=== { TJvHTHintWindow } ====================================================
|
||||
|
||||
constructor TJvHTHintWindow.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
HtLabel := TJvHTLabel.Create(Self);
|
||||
HtLabel.Parent := Self;
|
||||
HtLabel.SetBounds(2, 2, 0, 0);
|
||||
end;
|
||||
|
||||
procedure TJvHTHintWindow.Paint;
|
||||
begin
|
||||
end;
|
||||
|
||||
function TJvHTHintWindow.CalcHintRect(MaxWidth: Integer;
|
||||
const AHint: THintString; AData: Pointer): TRect;
|
||||
begin
|
||||
HtLabel.Caption := AHint;
|
||||
Result := Bounds(0, 0, HtLabel.Width + 6, HtLabel.Height + 2);
|
||||
if Application.HintHidePause > 0 then
|
||||
Application.HintHidePause :=
|
||||
Max(2500, // default
|
||||
Length(ItemHtPlain(AHint)) *
|
||||
(1000 div 20)); // 20 symbols per second
|
||||
end;
|
||||
|
||||
procedure RegisterHtHints;
|
||||
begin
|
||||
if Application.ShowHint then
|
||||
begin
|
||||
Application.ShowHint := False;
|
||||
HintWindowClass := TJvHTHintWindow;
|
||||
Application.ShowHint := True;
|
||||
end
|
||||
else
|
||||
HintWindowClass := TJvHTHintWindow;
|
||||
end;
|
||||
|
||||
end.
|
||||
1061
components/jvcllaz/run/JvHtControls.pas
Normal file
1061
components/jvcllaz/run/JvHtControls.pas
Normal file
File diff suppressed because it is too large
Load Diff
@ -32,7 +32,7 @@ unit JvJVCLUtils;
|
||||
|
||||
interface
|
||||
uses
|
||||
Classes, Graphics, JvTypes;
|
||||
Classes, Graphics, JvTypes, ImgList, LCLType, Types;
|
||||
|
||||
(******************** NOT CONVERTED
|
||||
// Transform an icon to a bitmap
|
||||
@ -670,9 +670,11 @@ procedure UpdateTrackFont(TrackFont, Font: TFont; TrackOptions: TJvTrackFontOpti
|
||||
// used for checkboxes and radiobuttons.
|
||||
// Originally from Mike Lischke
|
||||
function GetDefaultCheckBoxSize: TSize;
|
||||
********************)
|
||||
|
||||
function CanvasMaxTextHeight(Canvas: TCanvas): Integer;
|
||||
|
||||
(*******************
|
||||
{$IFDEF MSWINDOWS}
|
||||
// AllocateHWndEx works like Classes.AllocateHWnd but does not use any virtual memory pages
|
||||
function AllocateHWndEx(Method: TWndMethod; const AClassName: string = ''): THandle;
|
||||
@ -703,21 +705,35 @@ function StripAllFromResult(const Value: TModalResult): TModalResult;
|
||||
function SelectColorByLuminance(AColor, DarkColor, BrightColor: TColor): TColor;
|
||||
|
||||
// (peter3) implementation moved from JvHTControls.
|
||||
************)
|
||||
|
||||
type
|
||||
TJvHTMLCalcType = (htmlShow, htmlCalcWidth, htmlCalcHeight);
|
||||
TJvHTMLCalcType = (htmlShow, htmlCalcWidth, htmlCalcHeight, htmlHyperLink);
|
||||
|
||||
procedure HTMLDrawTextEx(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; var Width: Integer;
|
||||
CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;
|
||||
var LinkName: string; Scale: Integer = 100);
|
||||
function HTMLDrawText(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; Scale: Integer = 100): string;
|
||||
function HTMLTextWidth(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; Scale: Integer = 100): Integer;
|
||||
const State: TOwnerDrawState; const Text: string; out Width: Integer;
|
||||
CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; out MouseOnLink: Boolean;
|
||||
var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer = 100); overload;
|
||||
procedure HTMLDrawTextEx2(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; out Width, Height: Integer;
|
||||
CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; out MouseOnLink: Boolean;
|
||||
var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer = 100); overload;
|
||||
procedure HTMLDrawText(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double;
|
||||
Scale: Integer = 100);
|
||||
procedure HTMLDrawTextHL(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; MouseX, MouseY: Integer;
|
||||
SuperSubScriptRatio: Double; Scale: Integer = 100);
|
||||
function HTMLPlainText(const Text: string): string;
|
||||
function HTMLTextHeight(Canvas: TCanvas; const Text: string; Scale: Integer = 100): Integer;
|
||||
function HTMLTextExtent(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): TSize;
|
||||
function HTMLTextWidth(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;
|
||||
function HTMLTextHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;
|
||||
function HTMLPrepareText(const Text: string): string;
|
||||
|
||||
(*************
|
||||
|
||||
// This type is used to allow an easy migration from a TBitmap property to a
|
||||
// TPicture property. It is, for instance, used in TJvXPButton so that users
|
||||
// migrating to the JVCL can still open their applications and benefit
|
||||
@ -809,10 +825,15 @@ function GetGraphicObject(AStream: TStream): TGraphic; overload;
|
||||
function GetGraphicObject(AStream: TStream; ASender: TObject; AOnProc: TJvGetGraphicClassEvent): TGraphic; overload;
|
||||
********************)
|
||||
|
||||
function ReplaceComponentReference(This, NewReference: TComponent; var VarReference: TComponent): Boolean;
|
||||
function ReplaceImageListReference(This: TComponent; NewReference: TCustomImageList;
|
||||
var VarReference: TCustomImageList; ChangeLink: TChangeLink): Boolean;
|
||||
|
||||
implementation
|
||||
|
||||
(********************
|
||||
uses
|
||||
sysutils, LCLIntf, math;
|
||||
(********************
|
||||
SysConst,
|
||||
Consts,
|
||||
{$IFDEF MSWINDOWS}
|
||||
@ -6398,15 +6419,18 @@ begin
|
||||
end;
|
||||
end;
|
||||
|
||||
*****************)
|
||||
|
||||
function CanvasMaxTextHeight(Canvas: TCanvas): Integer;
|
||||
var
|
||||
tt: TTextMetric;
|
||||
begin
|
||||
// (ahuser) Qt returns different values for TextHeight('Ay') and TextHeigth(#1..#255)
|
||||
GetTextMetrics(Canvas.Handle, tt);
|
||||
GetTextMetrics(Canvas.Handle, tt{%H-});
|
||||
Result := tt.tmHeight;
|
||||
end;
|
||||
|
||||
(****************
|
||||
{$IFDEF MSWINDOWS}
|
||||
|
||||
//=== AllocateHWndEx =========================================================
|
||||
@ -6977,6 +7001,7 @@ begin
|
||||
else
|
||||
Result := BrightColor;
|
||||
end;
|
||||
***********)
|
||||
|
||||
const
|
||||
cBR = '<BR>';
|
||||
@ -6996,19 +7021,18 @@ const
|
||||
// moved from JvHTControls and renamed
|
||||
function HTMLPrepareText(const Text: string): string;
|
||||
type
|
||||
THtmlCode = packed record
|
||||
Html: string[10];
|
||||
Text: Char;
|
||||
THtmlCode = record
|
||||
Html: string;
|
||||
Text: UTF8String;
|
||||
end;
|
||||
const
|
||||
Conversions: array [0..6] of THtmlCode =
|
||||
(
|
||||
Conversions: array [0..6] of THtmlCode = (
|
||||
(Html: '&'; Text: '&'),
|
||||
(Html: '"'; Text: '"'),
|
||||
(Html: '®'; Text: '�'),
|
||||
(Html: '©'; Text: '�'),
|
||||
(Html: '™'; Text: '�'),
|
||||
(Html: '€'; Text: '�'),
|
||||
(Html: '®'; Text: #$C2#$AE),
|
||||
(Html: '©'; Text: #$C2#$A9),
|
||||
(Html: '™'; Text: #$E2#$84#$A2),
|
||||
(Html: '€'; Text: #$E2#$82#$AC),
|
||||
(Html: ' '; Text: ' ')
|
||||
);
|
||||
var
|
||||
@ -7016,8 +7040,7 @@ var
|
||||
begin
|
||||
Result := Text;
|
||||
for I := Low(Conversions) to High(Conversions) do
|
||||
with Conversions[I] do
|
||||
Result := StringReplace(Result, Html, Text, [rfReplaceAll, rfIgnoreCase]);
|
||||
Result := StringReplace(Result, Conversions[I].Html, Utf8ToAnsi(Conversions[I].Text), [rfReplaceAll, rfIgnoreCase]);
|
||||
Result := StringReplace(Result, sLineBreak, '', [rfReplaceAll, rfIgnoreCase]); // only <BR> can be new line
|
||||
Result := StringReplace(Result, cBR, sLineBreak, [rfReplaceAll, rfIgnoreCase]);
|
||||
Result := StringReplace(Result, cHR, cHR + sLineBreak, [rfReplaceAll, rfIgnoreCase]); // fixed <HR><BR>
|
||||
@ -7056,10 +7079,30 @@ begin
|
||||
Delete(Result, 1, Pos(cTagEnd, Result));
|
||||
end;
|
||||
|
||||
// wp: Made Width and MouseOnLink out parameters (were "var" in the original)
|
||||
// to silence the compiler
|
||||
procedure HTMLDrawTextEx(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; var Width: Integer;
|
||||
CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; var MouseOnLink: Boolean;
|
||||
var LinkName: string; Scale: Integer = 100);
|
||||
const State: TOwnerDrawState; const Text: string; out Width: Integer;
|
||||
CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; out MouseOnLink: Boolean;
|
||||
var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer);
|
||||
var
|
||||
H: Integer;
|
||||
begin
|
||||
HTMLDrawTextEx2(Canvas, Rect, State, Text, Width, H, CalcType, MouseX, MouseY, MouseOnLink,
|
||||
LinkName, SuperSubScriptRatio, Scale);
|
||||
if CalcType = htmlCalcHeight then
|
||||
Width := H;
|
||||
end;
|
||||
|
||||
type
|
||||
TScriptPosition = (spNormal, spSuperscript, spSubscript);
|
||||
|
||||
// wp: Make Width, Height and MouseOnLink "out" parameters
|
||||
// (they were "var" in the original) to silence the compiler
|
||||
procedure HTMLDrawTextEx2(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; out Width, Height: Integer;
|
||||
CalcType: TJvHTMLCalcType; MouseX, MouseY: Integer; out MouseOnLink: Boolean;
|
||||
var LinkName: string; SuperSubScriptRatio: Double; Scale: Integer);
|
||||
const
|
||||
DefaultLeft = 0; // (ahuser) was 2
|
||||
var
|
||||
@ -7082,6 +7125,7 @@ var
|
||||
RemFontColor,
|
||||
RemBrushColor: TColor;
|
||||
RemFontSize: Integer;
|
||||
ScriptPosition: TScriptPosition;
|
||||
|
||||
function ExtractPropertyValue(const Tag: string; PropName: string): string;
|
||||
var
|
||||
@ -7129,9 +7173,9 @@ var
|
||||
begin
|
||||
case Alignment of
|
||||
taRightJustify:
|
||||
Result := (Rect.Right {- Rect.Left}) - HTMLTextWidth(Canvas, Rect, State, Str, Scale);
|
||||
Result := (Rect.Right - Rect.Left) - HTMLTextWidth(Canvas, Rect, State, Str, Scale);
|
||||
taCenter:
|
||||
Result := (Rect.Right {- Rect.Left} - HTMLTextWidth(Canvas, Rect, State, Str)) div 2;
|
||||
Result := DefaultLeft + ((Rect.Right - Rect.Left) - HTMLTextWidth(Canvas, Rect, State, Str, SuperSubScriptRatio)) div 2;
|
||||
else
|
||||
Result := DefaultLeft;
|
||||
end;
|
||||
@ -7143,13 +7187,23 @@ var
|
||||
var
|
||||
Width, Height: Integer;
|
||||
R: TRect;
|
||||
OriginalFontSize: Integer;
|
||||
begin
|
||||
R := Rect;
|
||||
Inc(R.Left, CurLeft);
|
||||
if Assigned(Canvas) then
|
||||
begin
|
||||
OriginalFontSize := Canvas.Font.Size;
|
||||
try
|
||||
if ScriptPosition <> spNormal then
|
||||
Canvas.Font.Size := Round(Canvas.Font.Size * SuperSubScriptRatio);
|
||||
|
||||
Width := Canvas.TextWidth(M);
|
||||
Height := CanvasMaxTextHeight(Canvas);
|
||||
|
||||
if ScriptPosition = spSubscript then
|
||||
R.Top := R.Bottom - Height - 1;
|
||||
|
||||
if IsLink and not MouseOnLink then
|
||||
if (MouseY >= R.Top) and (MouseY <= R.Top + Height) and
|
||||
(MouseX >= R.Left) and (MouseX <= R.Left + Width) and
|
||||
@ -7166,6 +7220,9 @@ var
|
||||
Canvas.TextOut(R.Left, R.Top, M);
|
||||
end;
|
||||
CurLeft := CurLeft + Width;
|
||||
finally
|
||||
Canvas.Font.Size := OriginalFontSize;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
@ -7197,20 +7254,21 @@ begin
|
||||
OldFontColor := Canvas.Font.Color;
|
||||
OldBrushColor := Canvas.Brush.Color;
|
||||
OldBrushStyle := Canvas.Brush.Style;
|
||||
OldAlignment := Alignment;
|
||||
// OldAlignment := Alignment;
|
||||
RemFontColor := Canvas.Font.Color;
|
||||
RemBrushColor := Canvas.Brush.Color;
|
||||
RemFontSize := Canvas.Font.size;
|
||||
end;
|
||||
vStr := TStringList.Create;
|
||||
try
|
||||
Alignment := taLeftJustify;
|
||||
IsLink := False;
|
||||
MouseOnLink := False;
|
||||
vText := Text;
|
||||
vStr := TStringList.Create;
|
||||
vStr.Text := HTMLPrepareText(vText);
|
||||
vStr.Text := vText;
|
||||
LinkName := '';
|
||||
TempLink := '';
|
||||
ScriptPosition := spNormal;
|
||||
|
||||
Selected := (odSelected in State) or (odDisabled in State);
|
||||
Trans := (Canvas.Brush.Style = bsClear) and not selected;
|
||||
@ -7221,15 +7279,16 @@ begin
|
||||
vM := '';
|
||||
for vCount := 0 to vStr.Count - 1 do
|
||||
begin
|
||||
vText := vStr[vCount];
|
||||
vText := HTMLPrepareText(vStr[vCount]);
|
||||
CurLeft := CalcPos(vText);
|
||||
while Length(vText) > 0 do
|
||||
while vText <> '' do
|
||||
begin
|
||||
vM := HTMLBeforeTag(vText, True);
|
||||
vM := StringReplace(vM, '<', cLT, [rfReplaceAll, rfIgnoreCase]); // <--+ this must be here
|
||||
vM := StringReplace(vM, '>', cGT, [rfReplaceAll, rfIgnoreCase]); // <--/
|
||||
if GetChar(vText, 1) = cTagBegin then
|
||||
begin
|
||||
if vM <> '' then
|
||||
Draw(vM);
|
||||
if Pos(cTagEnd, vText) = 0 then
|
||||
Insert(cTagEnd, vText, 2);
|
||||
@ -7248,7 +7307,10 @@ begin
|
||||
'U':
|
||||
Style(fsUnderline, False);
|
||||
'S':
|
||||
begin
|
||||
ScriptPosition := spNormal;
|
||||
Style(fsStrikeOut, False);
|
||||
end;
|
||||
'F':
|
||||
begin
|
||||
if not Selected then // restore old colors
|
||||
@ -7277,7 +7339,7 @@ begin
|
||||
else
|
||||
Alignment := taLeftJustify;
|
||||
CurLeft := DefaultLeft;
|
||||
if CalcType = htmlShow then
|
||||
if CalcType in [htmlShow, htmlHyperLink] then
|
||||
CurLeft := CalcPos(vText);
|
||||
end
|
||||
else
|
||||
@ -7308,7 +7370,21 @@ begin
|
||||
'U':
|
||||
Style(fsUnderline, True);
|
||||
'S':
|
||||
begin
|
||||
if GetChar(vText, 4, True) = 'P' then
|
||||
begin
|
||||
ScriptPosition := spSuperscript;
|
||||
end
|
||||
else if GetChar(vText, 4, True) = 'B' then
|
||||
begin
|
||||
ScriptPosition := spSubscript;
|
||||
end
|
||||
else
|
||||
begin
|
||||
ScriptPosition := spNormal;
|
||||
Style(fsStrikeOut, True);
|
||||
end;
|
||||
end;
|
||||
'H':
|
||||
if (GetChar(vText, 3, True) = 'R') and Assigned(Canvas) then // HR
|
||||
begin
|
||||
@ -7329,7 +7405,7 @@ begin
|
||||
NewLine(HTMLDeleteTag(vText) <> '');
|
||||
end;
|
||||
'F':
|
||||
if (Pos(cTagEnd, vText) > 0) and (not Selected) and Assigned(Canvas) {and (CalcType = htmlShow)} then // F from FONT
|
||||
if (Pos(cTagEnd, vText) > 0) and (not Selected) and Assigned(Canvas) {and (CalcType in [htmlShow, htmlHyperLink])} then // F from FONT
|
||||
begin
|
||||
TagPrp := UpperCase(Copy(vText, 2, Pos(cTagEnd, vText) - 2));
|
||||
RemFontColor := Canvas.Font.Color;
|
||||
@ -7358,7 +7434,7 @@ begin
|
||||
if Pos('SIZE', TagPrp) > 0 then
|
||||
begin
|
||||
Prp := ExtractPropertyValue(TagPrp, 'SIZE');
|
||||
Canvas.Font.Size := StrToIntDef(Prp,2) * Canvas.Font.Size div 2;
|
||||
Canvas.Font.Size := StrToIntDef(Prp,2){ * Canvas.Font.Size div 2};
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
@ -7367,6 +7443,7 @@ begin
|
||||
vM := '';
|
||||
end;
|
||||
end;
|
||||
if vM <> '' then
|
||||
Draw(vM);
|
||||
NewLine;
|
||||
vM := '';
|
||||
@ -7385,20 +7462,33 @@ begin
|
||||
FreeAndNil(vStr);
|
||||
FreeAndNil(OldFont);
|
||||
end;
|
||||
if CalcType = htmlCalcHeight then
|
||||
Width := Rect.Top + CanvasMaxTextHeight(Canvas)
|
||||
else
|
||||
Width := Max(Width, CurLeft - DefaultLeft);
|
||||
Height := Rect.Top + CanvasMaxTextHeight(Canvas);
|
||||
end;
|
||||
|
||||
function HTMLDrawText(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; Scale: Integer = 100): string;
|
||||
// wp: I made this a procedure - it was a function in the original with the
|
||||
// result being unassigned.
|
||||
procedure HTMLDrawText(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer);
|
||||
var
|
||||
W: Integer;
|
||||
S: Boolean;
|
||||
St: string;
|
||||
begin
|
||||
HTMLDrawTextEx(Canvas, Rect, State, Text, W, htmlShow, 0, 0, S, St, Scale);
|
||||
HTMLDrawTextEx(Canvas, Rect, State, Text, W, htmlShow, 0, 0, S, St, SuperSubScriptRatio, Scale);
|
||||
end;
|
||||
|
||||
// wp: I made this a procedure - it was a function in the original with the
|
||||
// result being unassigned.
|
||||
procedure HTMLDrawTextHL(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; MouseX, MouseY: Integer;
|
||||
SuperSubScriptRatio: Double; Scale: Integer);
|
||||
var
|
||||
W: Integer;
|
||||
S: Boolean;
|
||||
St: string;
|
||||
begin
|
||||
HTMLDrawTextEx(Canvas, Rect, State, Text, W, htmlShow, MouseX, MouseY, S, St, SuperSubScriptRatio, Scale);
|
||||
end;
|
||||
|
||||
function HTMLPlainText(const Text: string): string;
|
||||
@ -7418,28 +7508,41 @@ begin
|
||||
Result := Result + S;
|
||||
end;
|
||||
|
||||
function HTMLTextWidth(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; Scale: Integer = 100): Integer;
|
||||
function HTMLTextExtent(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): TSize;
|
||||
var
|
||||
S: Boolean;
|
||||
St: string;
|
||||
begin
|
||||
HTMLDrawTextEx(Canvas, Rect, State, Text, Result, htmlCalcWidth, 0, 0, S, St);
|
||||
HTMLDrawTextEx2(Canvas, Rect, State, Text, Result.cx, Result.cy, htmlCalcWidth, 0, 0, S, St, SuperSubScriptRatio, Scale);
|
||||
if Result.cy = 0 then
|
||||
Result.cy := CanvasMaxTextHeight(Canvas);
|
||||
Inc(Result.cy);
|
||||
end;
|
||||
|
||||
function HTMLTextHeight(Canvas: TCanvas; const Text: string; Scale: Integer = 100): Integer;
|
||||
function HTMLTextWidth(Canvas: TCanvas; Rect: TRect;
|
||||
const State: TOwnerDrawState; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;
|
||||
var
|
||||
S: Boolean;
|
||||
St: string;
|
||||
begin
|
||||
HTMLDrawTextEx(Canvas, Rect, State, Text, Result, htmlCalcWidth, 0, 0, S, St, SuperSubScriptRatio, Scale);
|
||||
end;
|
||||
|
||||
function HTMLTextHeight(Canvas: TCanvas; const Text: string; SuperSubScriptRatio: Double; Scale: Integer = 100): Integer;
|
||||
var
|
||||
S: Boolean;
|
||||
St: string;
|
||||
R: TRect;
|
||||
begin
|
||||
R := Rect(0, 0, 0, 0);
|
||||
HTMLDrawTextEx(Canvas, R, [], Text, Result, htmlCalcHeight, 0, 0, S, St, Scale);
|
||||
HTMLDrawTextEx(Canvas, R, [], Text, Result, htmlCalcHeight, 0, 0, S, St, SuperSubScriptRatio, Scale);
|
||||
if Result = 0 then
|
||||
Result := CanvasMaxTextHeight(Canvas);
|
||||
Inc(Result);
|
||||
end;
|
||||
|
||||
(*************
|
||||
{ TJvPicture }
|
||||
procedure TJvPicture.ReadBitmapData(Stream: TStream);
|
||||
var
|
||||
@ -7682,6 +7785,43 @@ begin
|
||||
Result := nil;
|
||||
end;
|
||||
|
||||
******************)
|
||||
|
||||
function ReplaceComponentReference(This, NewReference: TComponent; var VarReference: TComponent): Boolean;
|
||||
begin
|
||||
Result := (VarReference <> NewReference) and Assigned(This);
|
||||
if Result then
|
||||
begin
|
||||
if Assigned(VarReference) then
|
||||
VarReference.RemoveFreeNotification(This);
|
||||
VarReference := NewReference;
|
||||
if Assigned(VarReference) then
|
||||
VarReference.FreeNotification(This);
|
||||
end;
|
||||
end;
|
||||
|
||||
function ReplaceImageListReference(This: TComponent; NewReference: TCustomImageList;
|
||||
var VarReference: TCustomImageList; ChangeLink: TChangeLink): Boolean;
|
||||
begin
|
||||
Result := (VarReference <> NewReference) and Assigned(This);
|
||||
if Result then
|
||||
begin
|
||||
if Assigned(VarReference) then
|
||||
begin
|
||||
VarReference.RemoveFreeNotification(This);
|
||||
VarReference.UnRegisterChanges(ChangeLink);
|
||||
end;
|
||||
VarReference := NewReference;
|
||||
if Assigned(VarReference) then
|
||||
begin
|
||||
VarReference.RegisterChanges(ChangeLink);
|
||||
VarReference.FreeNotification(This);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
(************
|
||||
|
||||
initialization
|
||||
InitScreenCursors;
|
||||
|
||||
|
||||
2366
components/jvcllaz/run/JvResources.pas
Normal file
2366
components/jvcllaz/run/JvResources.pas
Normal file
File diff suppressed because it is too large
Load Diff
@ -61,10 +61,10 @@ type
|
||||
Result: Longint;
|
||||
end;
|
||||
|
||||
(********************
|
||||
THintString = string;
|
||||
THintStringList = TStringList;
|
||||
|
||||
(********************
|
||||
{ JvExVCL classes }
|
||||
TInputKey = (ikAll, ikArrows, ikChars, ikButton, ikTabs, ikEdit, ikNative{, ikNav, ikEsc});
|
||||
TInputKeys = set of TInputKey;
|
||||
|
||||
993
components/jvcllaz/run/JvValidators.pas
Normal file
993
components/jvcllaz/run/JvValidators.pas
Normal file
@ -0,0 +1,993 @@
|
||||
{-----------------------------------------------------------------------------
|
||||
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/MPL-1.1.html
|
||||
|
||||
Software distributed under the License is distributed on an "AS IS" basis,
|
||||
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
|
||||
the specific language governing rights and limitations under the License.
|
||||
|
||||
The Original Code is: JvValidators.PAS, released on 2003-01-01.
|
||||
|
||||
The Initial Developer of the Original Code is Peter Th�rnqvist [peter3 at sourceforge dot net] .
|
||||
Portions created by Peter Th�rnqvist are Copyright (C) 2003 Peter Th�rnqvist.
|
||||
All Rights Reserved.
|
||||
|
||||
Contributor(s):
|
||||
|
||||
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
|
||||
located at http://jvcl.delphi-jedi.org
|
||||
|
||||
Known Issues:
|
||||
-----------------------------------------------------------------------------}
|
||||
// $Id$
|
||||
|
||||
unit JvValidators;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
// NB: this is here so a user can disable DB support if he wants to
|
||||
// NB2: this need not be defined in the design package because GetDataLink is
|
||||
// defined differently depending on this define
|
||||
{$DEFINE JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
DB,
|
||||
{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
SysUtils, Classes, Controls, Forms, {JvComponentBase,} JvErrorIndicator;
|
||||
|
||||
type
|
||||
EValidatorError = class(Exception);
|
||||
|
||||
// Implemented by classes that can return the value to validate against.
|
||||
// The validator classes first check if the ControlToValidate supports this interface
|
||||
// and if it does, uses the value returned from GetValidationPropertyValue instead of
|
||||
// extracting it from RTTI (using ControlToValidate and PropertyToValidate)
|
||||
// The good thing about implementing this interface is that the value to validate do
|
||||
// not need to be a published property but can be anything, even a calculated value
|
||||
IJvValidationProperty = interface
|
||||
['{564FD9F5-BE57-4559-A6AF-B0624C956E50}']
|
||||
function GetValidationPropertyValue: Variant;
|
||||
function GetValidationPropertyName: WideString;
|
||||
end;
|
||||
|
||||
IJvValidationSummary = interface
|
||||
['{F2E4F4E5-E831-4514-93C9-0E2ACA941DCF}']
|
||||
procedure BeginUpdate;
|
||||
procedure EndUpdate;
|
||||
procedure AddError(const ErrorMessage: string);
|
||||
procedure RemoveError(const ErrorMessage: string);
|
||||
end;
|
||||
|
||||
TJvBaseValidator = class;
|
||||
TJvValidators = class;
|
||||
TJvBaseValidatorClass = class of TJvBaseValidator;
|
||||
|
||||
TJvBaseValidator = class(TComponent)
|
||||
private
|
||||
FEnabled: Boolean;
|
||||
FValid: Boolean;
|
||||
FPropertyToValidate: string;
|
||||
FErrorMessage: string;
|
||||
FGroupName: string;
|
||||
FControlToValidate: TControl;
|
||||
FErrorControl: TControl;
|
||||
FValidator: TJvValidators;
|
||||
FOnValidateFailed: TNotifyEvent;
|
||||
|
||||
procedure SetControlToValidate(Value: TControl);
|
||||
procedure SetErrorControl(Value: TControl);
|
||||
protected
|
||||
function GetValidationPropertyValue: Variant; virtual;
|
||||
procedure SetValid(const Value: Boolean); virtual;
|
||||
function GetValid: Boolean; virtual;
|
||||
procedure DoValidateFailed; dynamic;
|
||||
procedure Validate; virtual; abstract;
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
procedure SetParentComponent(Value: TComponent); override;
|
||||
procedure ReadState(Reader: TReader); override;
|
||||
|
||||
// get the number of registered base validator classes
|
||||
class function BaseValidatorsCount: Integer;
|
||||
// get info on a registered class
|
||||
class procedure GetBaseValidatorInfo(Index: Integer; var DisplayName: string;
|
||||
var ABaseValidatorClass: TJvBaseValidatorClass);
|
||||
|
||||
public
|
||||
{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
// return a TDataLink if the control is a DB control or nil if is not
|
||||
function GetDataLink(AControl:TControl):TDataLink;virtual;
|
||||
{$ELSE}
|
||||
function GetDataLink(AControl:TControl):TObject;virtual;
|
||||
{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
// register a new base validator class. DisplayName is used by the design-time editor.
|
||||
// A class with an empty DisplayName will not sshow up in the editor
|
||||
class procedure RegisterBaseValidator(const DisplayName: string; AValidatorClass: TJvBaseValidatorClass);
|
||||
class procedure UnregisterBaseValidator(AValidatorClass: TJvBaseValidatorClass);
|
||||
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
|
||||
function GetParentComponent: TComponent; override;
|
||||
function HasParent: Boolean; override;
|
||||
property Value: Variant read GetValidationPropertyValue;
|
||||
published
|
||||
property Valid: Boolean read GetValid write SetValid default true;
|
||||
// the control that is used to align the error indicator (nil means that the ControlToValidate should be used)
|
||||
property ErrorControl: TControl read FErrorControl write SetErrorControl;
|
||||
// the control to validate
|
||||
property ControlToValidate: TControl read FControlToValidate write SetControlToValidate;
|
||||
// the property in ControlToValidate to validate against
|
||||
property PropertyToValidate: string read FPropertyToValidate write FPropertyToValidate;
|
||||
// make this validator a part of a group so it can be validated separately using Validate(GroupName)
|
||||
property GroupName:string read FGroupName write FGroupName;
|
||||
property Enabled: Boolean read FEnabled write FEnabled default true;
|
||||
// the message to display in case of error
|
||||
property ErrorMessage: string read FErrorMessage write FErrorMessage;
|
||||
// triggered when Valid is set to False
|
||||
property OnValidateFailed: TNotifyEvent read FOnValidateFailed write FOnValidateFailed;
|
||||
end;
|
||||
|
||||
TJvRequiredFieldValidator = class(TJvBaseValidator)
|
||||
private
|
||||
FAllowBlank: Boolean;
|
||||
protected
|
||||
procedure Validate; override;
|
||||
published
|
||||
property AllowBlank: Boolean read FAllowBlank write FAllowBlank default true;
|
||||
end;
|
||||
|
||||
TJvValidateCompareOperator = (vcoLessThan, vcoLessOrEqual, vcoEqual, vcoGreaterOrEqual, vcoGreaterThan, vcoNotEqual);
|
||||
|
||||
TJvCompareValidator = class(TJvBaseValidator)
|
||||
private
|
||||
FValueToCompare: Variant;
|
||||
FOperator: TJvValidateCompareOperator;
|
||||
protected
|
||||
procedure Validate; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
published
|
||||
property ValueToCompare: Variant read FValueToCompare write FValueToCompare;
|
||||
property CmpOperator: TJvValidateCompareOperator read FOperator write FOperator default vcoEqual;
|
||||
end;
|
||||
|
||||
TJvRangeValidator = class(TJvBaseValidator)
|
||||
private
|
||||
FMinimumValue: Variant;
|
||||
FMaximumValue: Variant;
|
||||
protected
|
||||
procedure Validate; override;
|
||||
published
|
||||
property MinimumValue: Variant read FMinimumValue write FMinimumValue;
|
||||
property MaximumValue: Variant read FMaximumValue write FMaximumValue;
|
||||
end;
|
||||
|
||||
TJvRegularExpressionValidator = class(TJvBaseValidator)
|
||||
private
|
||||
FValidationExpression: string;
|
||||
protected
|
||||
procedure Validate; override;
|
||||
published
|
||||
property ValidationExpression: string read FValidationExpression write FValidationExpression;
|
||||
end;
|
||||
|
||||
TJvCustomValidateEvent = procedure(Sender: TObject; ValueToValidate: Variant; var Valid: Boolean) of object;
|
||||
|
||||
TJvCustomValidator = class(TJvBaseValidator)
|
||||
private
|
||||
FOnValidate: TJvCustomValidateEvent;
|
||||
protected
|
||||
function DoValidate: Boolean; virtual;
|
||||
procedure Validate; override;
|
||||
published
|
||||
property OnValidate: TJvCustomValidateEvent read FOnValidate write FOnValidate;
|
||||
end;
|
||||
|
||||
// compares the properties of two controls
|
||||
// if CompareToControl implements the IJvValidationProperty interface, the value
|
||||
// to compare is taken from GetValidationPropertyValue, otherwise RTTI is used to get the
|
||||
// property value
|
||||
TJvControlsCompareValidator = class(TJvBaseValidator)
|
||||
private
|
||||
FCompareToControl: TControl;
|
||||
FCompareToProperty: string;
|
||||
FOperator: TJvValidateCompareOperator;
|
||||
FAllowNull: Boolean;
|
||||
procedure SetCompareToControl(const AValue: TControl);
|
||||
protected
|
||||
procedure Validate; override;
|
||||
function GetPropertyValueToCompare: Variant;
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
|
||||
published
|
||||
property CompareToControl: TControl read FCompareToControl write SetCompareToControl;
|
||||
property CompareToProperty: string read FCompareToProperty write FCompareToProperty;
|
||||
property CmpOperator: TJvValidateCompareOperator read FOperator write FOperator default vcoEqual;
|
||||
property AllowNull: Boolean read FAllowNull write FAllowNull default True;
|
||||
end;
|
||||
|
||||
TJvValidateFailEvent = procedure(Sender: TObject; BaseValidator: TJvBaseValidator; var Continue: Boolean) of object;
|
||||
|
||||
TJvValidators = class(TComponent)
|
||||
private
|
||||
FOnValidateFailed: TJvValidateFailEvent;
|
||||
FItems: TList;
|
||||
FValidationSummary: IJvValidationSummary;
|
||||
FErrorIndicator: IJvErrorIndicator;
|
||||
procedure SetValidationSummary(const Value: IJvValidationSummary);
|
||||
procedure SetErrorIndicator(const Value: IJvErrorIndicator);
|
||||
function GetCount: Integer;
|
||||
function GetItem(Index: Integer): TJvBaseValidator;
|
||||
protected
|
||||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||||
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
|
||||
function DoValidateFailed(const ABaseValidator: TJvBaseValidator): Boolean; dynamic;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
destructor Destroy; override;
|
||||
procedure Insert(AValidator: TJvBaseValidator);
|
||||
procedure Remove(AValidator: TJvBaseValidator);
|
||||
procedure Exchange(Index1, Index2: Integer);
|
||||
function Validate: Boolean; overload;
|
||||
function Validate(const GroupName:string): Boolean; overload;
|
||||
property Items[Index: Integer]: TJvBaseValidator read GetItem; default;
|
||||
property Count: Integer read GetCount;
|
||||
published
|
||||
property ValidationSummary: IJvValidationSummary read FValidationSummary write SetValidationSummary;
|
||||
property ErrorIndicator: IJvErrorIndicator read FErrorIndicator write SetErrorIndicator;
|
||||
property OnValidateFailed: TJvValidateFailEvent read FOnValidateFailed write FOnValidateFailed;
|
||||
end;
|
||||
|
||||
TJvValidationSummary = class(TComponent, IUnknown, IJvValidationSummary)
|
||||
private
|
||||
FUpdateCount: Integer;
|
||||
FPendingUpdates: Integer;
|
||||
FSummaries: TStringList;
|
||||
FOnChange: TNotifyEvent;
|
||||
FOnRemoveError: TNotifyEvent;
|
||||
FOnAddError: TNotifyEvent;
|
||||
function GetSummaries: TStrings;
|
||||
protected
|
||||
{ IJvValidationSummary }
|
||||
procedure AddError(const ErrorMessage: string);
|
||||
procedure RemoveError(const ErrorMessage: string);
|
||||
procedure BeginUpdate;
|
||||
procedure EndUpdate;
|
||||
|
||||
procedure Change; virtual;
|
||||
public
|
||||
destructor Destroy; override;
|
||||
property Summaries: TStrings read GetSummaries;
|
||||
published
|
||||
property OnChange: TNotifyEvent read FOnChange write FOnChange;
|
||||
property OnAddError: TNotifyEvent read FOnAddError write FOnAddError;
|
||||
property OnRemoveError: TNotifyEvent read FOnRemoveError write FOnRemoveError;
|
||||
end;
|
||||
|
||||
const
|
||||
cValidatorsDBValue = '(DBValue)';
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
DBCtrls,
|
||||
{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
Masks,
|
||||
Variants,
|
||||
TypInfo,
|
||||
// JclUnicode, // for reg exp support
|
||||
{JvTypes,} JvResources, JvJVCLUtils;
|
||||
|
||||
var
|
||||
GlobalValidatorsList: TStringList = nil;
|
||||
|
||||
procedure RegisterBaseValidators; forward;
|
||||
|
||||
function ValidatorsList: TStringList;
|
||||
begin
|
||||
if not Assigned(GlobalValidatorsList) then
|
||||
begin
|
||||
GlobalValidatorsList := TStringList.Create;
|
||||
// register
|
||||
//RegisterBaseValidators; is registered in initialization
|
||||
end;
|
||||
Result := GlobalValidatorsList;
|
||||
end;
|
||||
|
||||
procedure Debug(const Msg: string); overload;
|
||||
begin
|
||||
// Application.MessageBox(PChar(Msg),PChar('Debug'),MB_OK or MB_TASKMODAL)
|
||||
end;
|
||||
|
||||
procedure Debug(const Msg: string; const Fmt: array of const); overload;
|
||||
begin
|
||||
Debug(Format(Msg, Fmt));
|
||||
end;
|
||||
|
||||
function ComponentName(Comp: TComponent): string;
|
||||
begin
|
||||
if Comp = nil then
|
||||
Result := 'nil'
|
||||
else
|
||||
if Comp.Name <> '' then
|
||||
Result := Comp.Name
|
||||
else
|
||||
Result := Comp.ClassName;
|
||||
end;
|
||||
|
||||
//=== { TJvBaseValidator } ===================================================
|
||||
|
||||
constructor TJvBaseValidator.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FValid := True;
|
||||
FEnabled := True;
|
||||
end;
|
||||
|
||||
destructor TJvBaseValidator.Destroy;
|
||||
begin
|
||||
Debug('TJvBaseValidator.Destroy: FValidator is %s', [ComponentName(FValidator)]);
|
||||
ErrorControl := nil;
|
||||
ControlToValidate := nil;
|
||||
if FValidator <> nil then
|
||||
begin
|
||||
FValidator.Remove(Self);
|
||||
FValidator := nil;
|
||||
end;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
class procedure TJvBaseValidator.RegisterBaseValidator(const DisplayName: string; AValidatorClass:
|
||||
TJvBaseValidatorClass);
|
||||
begin
|
||||
if ValidatorsList.IndexOfObject(TObject(Pointer(AValidatorClass))) < 0 then
|
||||
begin
|
||||
Classes.RegisterClass(TPersistentClass(AValidatorClass));
|
||||
ValidatorsList.AddObject(DisplayName, TObject(Pointer(AValidatorClass)));
|
||||
end;
|
||||
end;
|
||||
|
||||
class procedure TJvBaseValidator.UnregisterBaseValidator(AValidatorClass: TJvBaseValidatorClass);
|
||||
var
|
||||
ClassIndex: Integer;
|
||||
begin
|
||||
ClassIndex := ValidatorsList.IndexOfObject(TObject(Pointer(AValidatorClass)));
|
||||
if ClassIndex >= 0 then
|
||||
begin
|
||||
Classes.UnregisterClass(TPersistentClass(AValidatorClass));
|
||||
ValidatorsList.Delete(ClassIndex);
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TJvBaseValidator.BaseValidatorsCount: Integer;
|
||||
begin
|
||||
Result := ValidatorsList.Count;
|
||||
end;
|
||||
|
||||
class procedure TJvBaseValidator.GetBaseValidatorInfo(Index: Integer;
|
||||
var DisplayName: string; var ABaseValidatorClass: TJvBaseValidatorClass);
|
||||
begin
|
||||
if (Index < 0) or (Index >= ValidatorsList.Count) then
|
||||
raise Exception.CreateFmt(RsEInvalidIndexd, [Index]);
|
||||
DisplayName := ValidatorsList[Index];
|
||||
ABaseValidatorClass := TJvBaseValidatorClass(ValidatorsList.Objects[Index]);
|
||||
end;
|
||||
|
||||
function TJvBaseValidator.GetValid: Boolean;
|
||||
begin
|
||||
Result := FValid;
|
||||
end;
|
||||
|
||||
function TJvBaseValidator.GetParentComponent: TComponent;
|
||||
begin
|
||||
Debug('TJvBaseValidator.GetParentComponent: Parent is %s', [ComponentName(FValidator)]);
|
||||
Result := FValidator;
|
||||
end;
|
||||
|
||||
function TJvBaseValidator.GetValidationPropertyValue: Variant;
|
||||
var
|
||||
ValProp: IJvValidationProperty;
|
||||
PropInfo: PPropInfo;
|
||||
{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
DataLink:TDataLink;
|
||||
{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
begin
|
||||
Result := Null;
|
||||
if FControlToValidate <> nil then
|
||||
begin
|
||||
if Supports(FControlToValidate, IJvValidationProperty, ValProp) then
|
||||
Result := ValProp.GetValidationPropertyValue
|
||||
{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
else if AnsiSameText(FPropertyToValidate,cValidatorsDBValue) then
|
||||
begin
|
||||
DataLink := GetDataLink(FControlToValidate);
|
||||
if (DataLink is TFieldDataLink) and (TFieldDataLink(DataLink).Field <> nil) then
|
||||
Result := TFieldDataLink(DataLink).Field.DisplayText;
|
||||
end
|
||||
{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
else if FPropertyToValidate <> '' then
|
||||
begin
|
||||
PropInfo := GetPropInfo(FControlToValidate, FPropertyToValidate);
|
||||
if (PropInfo <> nil) and (PropInfo^.GetProc <> nil) then
|
||||
begin
|
||||
Result := GetPropValue(FControlToValidate, FPropertyToValidate, False);
|
||||
if (PropInfo^.PropType = TypeInfo(TDateTime)) or
|
||||
(PropInfo^.PropType = TypeInfo(TDate)) or
|
||||
(PropInfo^.PropType = TypeInfo(TTime)) then
|
||||
Result := VarAsType(Result, varDate);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TJvBaseValidator.HasParent: Boolean;
|
||||
begin
|
||||
Debug('TJvBaseValidator.HasParent');
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if Operation = opRemove then
|
||||
begin
|
||||
if AComponent = ControlToValidate then
|
||||
ControlToValidate := nil;
|
||||
if AComponent = ErrorControl then
|
||||
ErrorControl := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.SetValid(const Value: Boolean);
|
||||
begin
|
||||
FValid := Value;
|
||||
if not FValid then
|
||||
DoValidateFailed;
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.SetControlToValidate(Value: TControl);
|
||||
var
|
||||
Obj: IJvValidationProperty;
|
||||
begin
|
||||
if ReplaceComponentReference(Self, Value, TComponent(FControlToValidate)) then
|
||||
if FControlToValidate <> nil then
|
||||
if not (csLoading in ComponentState) then
|
||||
begin
|
||||
if Supports(FControlToValidate, IJvValidationProperty, Obj) then
|
||||
PropertyToValidate := UTF8Encode(Obj.GetValidationPropertyName)
|
||||
else
|
||||
PropertyToValidate := '';
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.SetErrorControl(Value: TControl);
|
||||
begin
|
||||
ReplaceComponentReference(Self, Value, TComponent(FErrorControl));
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.SetParentComponent(Value: TComponent);
|
||||
begin
|
||||
if not (csLoading in ComponentState) then
|
||||
begin
|
||||
Debug('TJvBaseValidator.SetParentComponent: Parent is %s, changing to %s',
|
||||
[ComponentName(FValidator), ComponentName(Value)]);
|
||||
if FValidator <> nil then
|
||||
begin
|
||||
Debug('FValidator.Remove');
|
||||
FValidator.Remove(Self);
|
||||
end;
|
||||
if (Value <> nil) and (Value is TJvValidators) then
|
||||
begin
|
||||
Debug('FValidator.Insert');
|
||||
TJvValidators(Value).Insert(Self);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.ReadState(Reader: TReader);
|
||||
begin
|
||||
inherited ReadState(Reader);
|
||||
Debug('TJvBaseValidator.ReadState: Reader.Parent is %s', [ComponentName(Reader.Parent)]);
|
||||
if Reader.Parent is TJvValidators then
|
||||
begin
|
||||
if FValidator <> nil then
|
||||
FValidator.Remove(Self);
|
||||
FValidator := TJvValidators(Reader.Parent);
|
||||
FValidator.Insert(Self);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvBaseValidator.DoValidateFailed;
|
||||
begin
|
||||
if Assigned(FOnValidateFailed) then
|
||||
FOnValidateFailed(Self);
|
||||
end;
|
||||
|
||||
{$IFDEF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
function TJvBaseValidator.GetDataLink(AControl:TControl): TDataLink;
|
||||
begin
|
||||
if AControl <> nil then
|
||||
Result := TDataLink(AControl.Perform(CM_GETDATALINK, 0, 0))
|
||||
else
|
||||
Result := nil;
|
||||
end;
|
||||
{$ELSE}
|
||||
function TJvBaseValidator.GetDataLink(AControl:TControl):TObject;
|
||||
begin
|
||||
Result := nil;
|
||||
end;
|
||||
{$ENDIF JVVALIDATORS_SUPPORTS_DBCONTROLS}
|
||||
|
||||
|
||||
//=== { TJvRequiredFieldValidator } ==========================================
|
||||
|
||||
procedure TJvRequiredFieldValidator.Validate;
|
||||
var
|
||||
R: Variant;
|
||||
begin
|
||||
R := GetValidationPropertyValue;
|
||||
case VarType(R) of
|
||||
varDate:
|
||||
Valid := VarCompareValue(R, 0) <> vrEqual; // zero is the invalid value for dates
|
||||
varSmallint,
|
||||
varInteger,
|
||||
varSingle,
|
||||
varDouble,
|
||||
varCurrency,
|
||||
varBoolean,
|
||||
varByte:
|
||||
; // nothing to do because all values are valid
|
||||
else
|
||||
if FAllowBlank then
|
||||
Valid := VarCompareValue(R, '') <> vrEqual
|
||||
else
|
||||
Valid := Trim(VarToStr(R)) <> '';
|
||||
end;
|
||||
end;
|
||||
|
||||
//=== { TJvCustomValidator } =================================================
|
||||
|
||||
function TJvCustomValidator.DoValidate: Boolean;
|
||||
begin
|
||||
Result := Valid;
|
||||
if Assigned(FOnValidate) then
|
||||
FOnValidate(Self, GetValidationPropertyValue, Result);
|
||||
end;
|
||||
|
||||
procedure TJvCustomValidator.Validate;
|
||||
begin
|
||||
Valid := DoValidate;
|
||||
end;
|
||||
|
||||
//=== { TJvRegularExpressionValidator } ======================================
|
||||
|
||||
function MatchesMask(const Filename, Mask: string{;
|
||||
const SearchFlags: TSearchFlags = [sfCaseSensitive]}): Boolean;
|
||||
{var
|
||||
URE: TURESearch;
|
||||
SL: TWideStringList;}
|
||||
begin
|
||||
Result := Masks.MatchesMask(Filename, Mask);
|
||||
(*
|
||||
// use the regexp engine in JclUnicode
|
||||
SL := TWideStringList.Create;
|
||||
try
|
||||
URE := TURESearch.Create(SL);
|
||||
try
|
||||
URE.FindPrepare(Mask, SearchFlags);
|
||||
// this could be overkill for long strings and many matches,
|
||||
// but it's a lot simpler than calling FindFirst...
|
||||
Result := URE.FindAll(Filename);
|
||||
finally
|
||||
URE.Free;
|
||||
end;
|
||||
finally
|
||||
SL.Free;
|
||||
end;
|
||||
*)
|
||||
end;
|
||||
|
||||
procedure TJvRegularExpressionValidator.Validate;
|
||||
var
|
||||
R: string;
|
||||
begin
|
||||
R := VarToStr(GetValidationPropertyValue);
|
||||
Valid := (R = ValidationExpression) or MatchesMask(R, ValidationExpression);
|
||||
end;
|
||||
|
||||
//=== { TJvCompareValidator } ================================================
|
||||
|
||||
constructor TJvCompareValidator.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FOperator := vcoEqual;
|
||||
end;
|
||||
|
||||
procedure TJvCompareValidator.Validate;
|
||||
var
|
||||
VR: TVariantRelationship;
|
||||
begin
|
||||
VR := VarCompareValue(GetValidationPropertyValue, ValueToCompare);
|
||||
case CmpOperator of
|
||||
vcoLessThan:
|
||||
Valid := VR = vrLessThan;
|
||||
vcoLessOrEqual:
|
||||
Valid := (VR = vrLessThan) or (VR = vrEqual);
|
||||
vcoEqual:
|
||||
Valid := (VR = vrEqual);
|
||||
vcoGreaterOrEqual:
|
||||
Valid := (VR = vrGreaterThan) or (VR = vrEqual);
|
||||
vcoGreaterThan:
|
||||
Valid := (VR = vrGreaterThan);
|
||||
vcoNotEqual:
|
||||
Valid := VR <> vrEqual;
|
||||
end;
|
||||
end;
|
||||
|
||||
//=== { TJvRangeValidator } ==================================================
|
||||
|
||||
procedure TJvRangeValidator.Validate;
|
||||
var
|
||||
VR: TVariantRelationship;
|
||||
begin
|
||||
VR := VarCompareValue(GetValidationPropertyValue, MinimumValue);
|
||||
Valid := (VR = vrGreaterThan) or (VR = vrEqual);
|
||||
if Valid then
|
||||
begin
|
||||
VR := VarCompareValue(GetValidationPropertyValue, MaximumValue);
|
||||
Valid := (VR = vrLessThan) or (VR = vrEqual);
|
||||
end;
|
||||
end;
|
||||
|
||||
//=== { TJvControlsCompareValidator } ========================================
|
||||
|
||||
constructor TJvControlsCompareValidator.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FAllowNull := True;
|
||||
FOperator := vcoEqual;
|
||||
end;
|
||||
|
||||
function TJvControlsCompareValidator.GetPropertyValueToCompare: Variant;
|
||||
var
|
||||
ValProp: IJvValidationProperty;
|
||||
PropInfo: PPropInfo;
|
||||
begin
|
||||
Result := Null;
|
||||
if FCompareToControl <> nil then
|
||||
begin
|
||||
if Supports(FCompareToControl, IJvValidationProperty, ValProp) then
|
||||
Result := ValProp.GetValidationPropertyValue
|
||||
else
|
||||
if FCompareToProperty <> '' then
|
||||
begin
|
||||
PropInfo := GetPropInfo(FCompareToControl, FCompareToProperty);
|
||||
if (PropInfo <> nil) and (PropInfo^.GetProc <> nil) then
|
||||
Result := GetPropValue(FCompareToControl, FCompareToProperty, False);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvControlsCompareValidator.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if (Operation = opRemove) and (AComponent = CompareToControl) then
|
||||
CompareToControl := nil;
|
||||
end;
|
||||
|
||||
procedure TJvControlsCompareValidator.SetCompareToControl(const AValue: TControl);
|
||||
var
|
||||
Obj: IJvValidationProperty;
|
||||
begin
|
||||
if ReplaceComponentReference(Self, AValue, TComponent(FCompareToControl)) then
|
||||
if FCompareToControl <> nil then
|
||||
begin
|
||||
if not (csLoading in ComponentState) then
|
||||
begin
|
||||
if Supports(FCompareToControl, IJvValidationProperty, Obj) then
|
||||
CompareToProperty := UTF8Encode(Obj.GetValidationPropertyName)
|
||||
else
|
||||
CompareToProperty := '';
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvControlsCompareValidator.Validate;
|
||||
var
|
||||
Val1, Val2: Variant;
|
||||
VR: TVariantRelationship;
|
||||
begin
|
||||
Val1 := GetValidationPropertyValue;
|
||||
Val2 := GetPropertyValueToCompare;
|
||||
if not AllowNull and
|
||||
((TVarData(Val1).VType in [varEmpty, varNull]) or (TVarData(Val2).VType in [varEmpty, varNull])) then
|
||||
begin
|
||||
Valid := False;
|
||||
Exit;
|
||||
end;
|
||||
VR := VarCompareValue(Val1, Val2);
|
||||
case CmpOperator of
|
||||
vcoLessThan:
|
||||
Valid := VR = vrLessThan;
|
||||
vcoLessOrEqual:
|
||||
Valid := (VR = vrLessThan) or (VR = vrEqual);
|
||||
vcoEqual:
|
||||
Valid := (VR = vrEqual);
|
||||
vcoGreaterOrEqual:
|
||||
Valid := (VR = vrGreaterThan) or (VR = vrEqual);
|
||||
vcoGreaterThan:
|
||||
Valid := (VR = vrGreaterThan);
|
||||
vcoNotEqual:
|
||||
Valid := (VR <> vrEqual);
|
||||
end;
|
||||
end;
|
||||
|
||||
//=== { TJvValidators } ======================================================
|
||||
|
||||
constructor TJvValidators.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
FItems := TList.Create;
|
||||
end;
|
||||
|
||||
destructor TJvValidators.Destroy;
|
||||
var
|
||||
V: TJvBaseValidator;
|
||||
begin
|
||||
Debug('TJvValidators.Destroy: Count is %d', [FItems.Count]);
|
||||
while FItems.Count > 0 do
|
||||
begin
|
||||
V := TJvBaseValidator(FItems.Last);
|
||||
V.FValidator := nil;
|
||||
V.Free;
|
||||
FItems.Delete(FItems.Count - 1);
|
||||
end;
|
||||
FItems.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
function TJvValidators.DoValidateFailed(const ABaseValidator: TJvBaseValidator): Boolean;
|
||||
begin
|
||||
Result := True;
|
||||
if Assigned(FOnValidateFailed) then
|
||||
FOnValidateFailed(Self, ABaseValidator, Result);
|
||||
end;
|
||||
|
||||
function TJvValidators.Validate(const GroupName:string): Boolean;
|
||||
var
|
||||
I: Integer;
|
||||
Controls: TList;
|
||||
ErrCtrl: TControl;
|
||||
begin
|
||||
Result := True;
|
||||
if ValidationSummary <> nil then
|
||||
FValidationSummary.BeginUpdate;
|
||||
try
|
||||
Controls := TList.Create;
|
||||
if FErrorIndicator <> nil then
|
||||
FErrorIndicator.BeginUpdate;
|
||||
try
|
||||
{ Get all controls that should be validated }
|
||||
if FErrorIndicator <> nil then
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
ErrCtrl := Items[i].ErrorControl;
|
||||
if ErrCtrl = nil then
|
||||
ErrCtrl := Items[i].ControlToValidate;
|
||||
if ErrCtrl <> nil then
|
||||
if Controls.IndexOf(ErrCtrl) = -1 then
|
||||
Controls.Add(ErrCtrl);
|
||||
end;
|
||||
|
||||
for I := 0 to Count - 1 do
|
||||
begin
|
||||
if Items[I].Enabled and ((Items[I].GroupName = '') or AnsiSameText(GroupName, Items[I].GroupName)) then
|
||||
begin
|
||||
Items[I].Validate;
|
||||
if not Items[I].Valid then
|
||||
begin
|
||||
if (Items[I].ErrorMessage <> '') and (Items[I].ControlToValidate <> nil) then
|
||||
begin
|
||||
ErrCtrl := Items[I].ErrorControl;
|
||||
if ErrCtrl = nil then
|
||||
ErrCtrl := Items[i].ControlToValidate;
|
||||
|
||||
if ValidationSummary <> nil then
|
||||
FValidationSummary.AddError(Items[I].ErrorMessage);
|
||||
if ErrorIndicator <> nil then
|
||||
FErrorIndicator.SetError(ErrCtrl, UTF8Decode(Items[I].ErrorMessage));
|
||||
if FErrorIndicator <> nil then
|
||||
Controls.Remove(ErrCtrl); { control is not valid }
|
||||
end;
|
||||
Result := False;
|
||||
if not DoValidateFailed(Items[I]) then
|
||||
Exit;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{ Clear ErrorIndicators for controls that are valid }
|
||||
if FErrorIndicator <> nil then
|
||||
for I := 0 to Controls.Count - 1 do
|
||||
FErrorIndicator.SetError(TControl(Controls[I]), ''); // clear error indicator
|
||||
finally
|
||||
if FErrorIndicator <> nil then
|
||||
FErrorIndicator.EndUpdate;
|
||||
Controls.Free;
|
||||
end;
|
||||
finally
|
||||
if ValidationSummary <> nil then
|
||||
FValidationSummary.EndUpdate;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TJvValidators.Validate: Boolean;
|
||||
begin
|
||||
Result := Validate('');
|
||||
end;
|
||||
|
||||
procedure TJvValidators.Notification(AComponent: TComponent;
|
||||
Operation: TOperation);
|
||||
begin
|
||||
inherited Notification(AComponent, Operation);
|
||||
if Operation = opRemove then
|
||||
begin
|
||||
if Assigned(ValidationSummary) and AComponent.IsImplementorOf(ValidationSummary) then
|
||||
ValidationSummary := nil;
|
||||
if Assigned(ErrorIndicator) and AComponent.IsImplementorOf(ErrorIndicator) then
|
||||
ErrorIndicator := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvValidators.GetChildren(Proc: TGetChildProc; Root: TComponent);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
Debug('TJvValidators.GetChildren: Count is %d, Root is %s', [Count, ComponentName(Root)]);
|
||||
for I := 0 to Count - 1 do
|
||||
Proc(Items[I]);
|
||||
end;
|
||||
|
||||
procedure TJvValidators.SetValidationSummary(const Value: IJvValidationSummary);
|
||||
begin
|
||||
ReferenceInterface(FValidationSummary, opRemove);
|
||||
FValidationSummary := Value;
|
||||
ReferenceInterface(FValidationSummary, opInsert);
|
||||
end;
|
||||
|
||||
procedure TJvValidators.Insert(AValidator: TJvBaseValidator);
|
||||
begin
|
||||
Debug('TJvValidators.Insert: inserting %s', [ComponentName(AValidator)]);
|
||||
Assert(AValidator <> nil, RsEInsertNilValidator);
|
||||
AValidator.FValidator := Self;
|
||||
if FItems.IndexOf(AValidator) < 0 then
|
||||
FItems.Add(AValidator);
|
||||
end;
|
||||
|
||||
procedure TJvValidators.Remove(AValidator: TJvBaseValidator);
|
||||
begin
|
||||
Debug('TJvValidators.Remove: removing %s', [ComponentName(AValidator)]);
|
||||
Assert(AValidator <> nil, RsERemoveNilValidator);
|
||||
Assert(AValidator.FValidator = Self, RsEValidatorNotChild);
|
||||
AValidator.FValidator := nil;
|
||||
FItems.Remove(AValidator);
|
||||
end;
|
||||
|
||||
function TJvValidators.GetCount: Integer;
|
||||
begin
|
||||
Result := FItems.Count;
|
||||
end;
|
||||
|
||||
function TJvValidators.GetItem(Index: Integer): TJvBaseValidator;
|
||||
begin
|
||||
Result := TJvBaseValidator(FItems[Index]);
|
||||
end;
|
||||
|
||||
procedure TJvValidators.Exchange(Index1, Index2: Integer);
|
||||
begin
|
||||
FItems.Exchange(Index1, Index2);
|
||||
end;
|
||||
|
||||
procedure TJvValidators.SetErrorIndicator(const Value: IJvErrorIndicator);
|
||||
begin
|
||||
ReferenceInterface(FErrorIndicator, opRemove);
|
||||
FErrorIndicator := Value;
|
||||
ReferenceInterface(FErrorIndicator, opInsert);
|
||||
end;
|
||||
|
||||
//=== { TJvValidationSummary } ===============================================
|
||||
|
||||
destructor TJvValidationSummary.Destroy;
|
||||
begin
|
||||
FSummaries.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
procedure TJvValidationSummary.AddError(const ErrorMessage: string);
|
||||
begin
|
||||
if Summaries.IndexOf(ErrorMessage) < 0 then
|
||||
begin
|
||||
Summaries.Add(ErrorMessage);
|
||||
if (FUpdateCount = 0) and Assigned(FOnAddError) then
|
||||
FOnAddError(Self);
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TJvValidationSummary.RemoveError(const ErrorMessage: string);
|
||||
var
|
||||
I: Integer;
|
||||
begin
|
||||
I := Summaries.IndexOf(ErrorMessage);
|
||||
if I > -1 then
|
||||
begin
|
||||
Summaries.Delete(I);
|
||||
if (FUpdateCount = 0) and Assigned(FOnRemoveError) then
|
||||
FOnRemoveError(Self);
|
||||
Change;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TJvValidationSummary.GetSummaries: TStrings;
|
||||
begin
|
||||
if FSummaries = nil then
|
||||
FSummaries := TStringList.Create;
|
||||
Result := FSummaries;
|
||||
end;
|
||||
|
||||
procedure TJvValidationSummary.Change;
|
||||
begin
|
||||
if FUpdateCount <> 0 then
|
||||
begin
|
||||
Inc(FPendingUpdates);
|
||||
Exit;
|
||||
end;
|
||||
if Assigned(FOnChange) then
|
||||
FOnChange(Self);
|
||||
end;
|
||||
|
||||
procedure TJvValidationSummary.BeginUpdate;
|
||||
begin
|
||||
Inc(FUpdateCount);
|
||||
end;
|
||||
|
||||
procedure TJvValidationSummary.EndUpdate;
|
||||
begin
|
||||
Dec(FUpdateCount);
|
||||
if FUpdateCount < 0 then
|
||||
FUpdateCount := 0;
|
||||
if (FUpdateCount = 0) and (FPendingUpdates > 0) then
|
||||
begin
|
||||
Change;
|
||||
FPendingUpdates := 0;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure RegisterBaseValidators;
|
||||
begin
|
||||
TJvBaseValidator.RegisterBaseValidator('Required Field Validator', TJvRequiredFieldValidator);
|
||||
TJvBaseValidator.RegisterBaseValidator('Compare Validator', TJvCompareValidator);
|
||||
TJvBaseValidator.RegisterBaseValidator('Range Validator', TJvRangeValidator);
|
||||
TJvBaseValidator.RegisterBaseValidator('Regular Expression Validator', TJvRegularExpressionValidator);
|
||||
TJvBaseValidator.RegisterBaseValidator('Custom Validator', TJvCustomValidator);
|
||||
TJvBaseValidator.RegisterBaseValidator('Controls Compare Validator', TJvControlsCompareValidator);
|
||||
end;
|
||||
|
||||
|
||||
initialization
|
||||
// (p3) do NOT touch! This is required to make the registration work on formulars!!!
|
||||
RegisterBaseValidators;
|
||||
|
||||
finalization
|
||||
FreeAndNil(GlobalValidatorsList);
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user