diff --git a/components/jvcllaz/design/JvDB/JvDBReg.pas b/components/jvcllaz/design/JvDB/JvDBReg.pas
index dfd349702..77dd2f504 100644
--- a/components/jvcllaz/design/JvDB/JvDBReg.pas
+++ b/components/jvcllaz/design/JvDB/JvDBReg.pas
@@ -16,7 +16,7 @@ implementation
uses
Classes, JvDsgnConsts, //JvDBSearchCombobox,
- JvDBSearchEdit, JvDBTreeView, JvDBControls, JvDBHTLabel;
+ JvDBSearchEdit, JvDBTreeView, JvDBControls, JvDBHTLabel, JvDBLookup;
procedure Register;
const
@@ -42,7 +42,8 @@ begin
TJvDBSearchEdit,
// TJvDBSearchCombobox,
TJvDBTreeView,
- TJvDBHTLabel
+ TJvDBHTLabel,
+ TJvDBLookupList, TJvDBLookupCombo
]);
RegisterPropertyEditor(TypeInfo(string), TJvDBTreeView, cItemField, TFieldProperty); //TJvDataFieldProperty);
diff --git a/components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpi b/components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpi
new file mode 100644
index 000000000..4897edaaf
--- /dev/null
+++ b/components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpi
@@ -0,0 +1,73 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpr b/components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpr
new file mode 100644
index 000000000..8e57fd244
--- /dev/null
+++ b/components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpr
@@ -0,0 +1,22 @@
+program JvDBLookupDemo;
+
+{$mode objfpc}{$H+}
+
+uses
+ {$IFDEF UNIX}{$IFDEF UseCThreads}
+ cthreads,
+ {$ENDIF}{$ENDIF}
+ Interfaces, // this includes the LCL widgetset
+ Forms, main
+ { you can add units after this };
+
+{$R *.res}
+
+begin
+ RequireDerivedFormResource := True;
+ Application.Scaled := True;
+ Application.Initialize;
+ Application.CreateForm(TForm1, Form1);
+ Application.Run;
+end.
+
diff --git a/components/jvcllaz/examples/JvDBLookup/main.lfm b/components/jvcllaz/examples/JvDBLookup/main.lfm
new file mode 100644
index 000000000..8357b2b97
--- /dev/null
+++ b/components/jvcllaz/examples/JvDBLookup/main.lfm
@@ -0,0 +1,335 @@
+object Form1: TForm1
+ Left = 298
+ Height = 331
+ Top = 119
+ Width = 433
+ Caption = 'JvDBLookup controls'
+ ClientHeight = 331
+ ClientWidth = 433
+ OnShow = FormShow
+ LCLVersion = '2.1.0.0'
+ object DBGrid1: TDBGrid
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Control = Owner
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = DBEdit1
+ Left = 8
+ Height = 129
+ Top = 8
+ Width = 417
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Around = 8
+ Color = clWindow
+ Columns = <>
+ DataSource = DSCities
+ TabOrder = 0
+ end
+ object JvDBLookupList1: TJvDBLookupList
+ AnchorSideLeft.Control = Owner
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = JvDBLookupCombo1
+ Left = 8
+ Height = 116
+ Top = 176
+ Width = 417
+ BorderSpacing.Left = 8
+ BorderSpacing.Top = 8
+ BorderSpacing.Right = 8
+ DataField = 'CITY_ID'
+ DataSource = DSSomeData
+ DisplayEmpty = 'none...'
+ EmptyItemColor = clSilver
+ Anchors = [akLeft, akRight, akBottom]
+ ImageList = ImageList1
+ LookupField = 'ID'
+ LookupDisplay = 'NAME;COUNTRY'
+ LookupSource = DSCities
+ TabOrder = 1
+ UseRecordCount = True
+ OnGetImageIndex = JvDBLookupList1GetImageIndex
+ end
+ object DBEdit1: TDBEdit
+ AnchorSideLeft.Control = DBGrid1
+ AnchorSideTop.Side = asrBottom
+ AnchorSideBottom.Control = JvDBLookupList1
+ Left = 8
+ Height = 23
+ Top = 145
+ Width = 112
+ DataField = 'CITY_ID'
+ DataSource = DSSomeData
+ Anchors = [akLeft, akBottom]
+ CharCase = ecNormal
+ MaxLength = 0
+ TabOrder = 2
+ end
+ object JvDBLookupCombo1: TJvDBLookupCombo
+ AnchorSideLeft.Control = Owner
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = Owner
+ AnchorSideBottom.Side = asrBottom
+ Left = 8
+ Height = 23
+ Top = 300
+ Width = 417
+ BorderSpacing.Around = 8
+ DisplayAllFields = True
+ DataField = 'CITY_ID'
+ DataSource = DSSomeData
+ DisplayEmpty = 'none...'
+ EmptyItemColor = clSilver
+ Anchors = [akLeft, akRight, akBottom]
+ ImageList = ImageList1
+ LookupField = 'ID'
+ LookupDisplay = 'NAME;COUNTRY'
+ LookupSource = DSCities
+ TabOrder = 3
+ UseRecordCount = True
+ OnGetImageIndex = JvDBLookupList1GetImageIndex
+ end
+ object SomeData: TBufDataset
+ FieldDefs = <
+ item
+ Name = 'CITY_ID'
+ DataType = ftInteger
+ end>
+ left = 183
+ top = 134
+ end
+ object Cities: TBufDataset
+ FieldDefs = <
+ item
+ Name = 'ID'
+ DataType = ftInteger
+ end
+ item
+ Name = 'NAME'
+ DataType = ftString
+ Size = 16
+ end
+ item
+ Name = 'COUNTRY'
+ DataType = ftString
+ Size = 16
+ end
+ item
+ Name = 'FLAG'
+ DataType = ftInteger
+ end>
+ left = 264
+ top = 134
+ end
+ object ImageList1: TImageList
+ left = 224
+ top = 240
+ Bitmap = {
+ 4C69060000001000000010000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000058483BE0645442E0645442E0645442E06454
+ 42E0645442E0645442E0645442E0645442E0645442E0645442E0645442E06454
+ 42E0645442E0645442E058483BE0645240E577644BFF77644BFF77644BFF7764
+ 4BFF77644BFF77644BFF77644BFF77644BFF77644BFF77644BFF77644BFF7764
+ 4BFF77644BFF77644BFF645240E5645240E577644BFF77644BFF77644BFF7764
+ 4BFF77644BFF77644BFF77644BFF77644BFF77644BFF77644BFF77644BFF7764
+ 4BFF77644BFF77644BFF645240E5584B4AF8645650F8645650F8645650F86456
+ 50F8645650F8645650F8645650F8645650F8645650F8645650F8645650F86456
+ 50F8645650F8645650F8584B4AF86C6CDFE58F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE56C6CDFE58F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE56C6CDFE58F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5595DD6EF6C72E2F16C72E2F16C72E2F16C72
+ E2F16C72E2F16C72E2F16C72E2F16C72E2F16C72E2F16C72E2F16C72E2F16C72
+ E2F16C72E2F16C72E2F1595DD6EF8ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE58ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE58ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE581CEF8E08EDAFAE08EDAFAE08EDAFAE08EDA
+ FAE08EDAFAE08EDAFAE08EDAFAE08EDAFAE08EDAFAE08EDAFAE08EDAFAE08EDA
+ FAE08EDAFAE08EDAFAE081CEF8E0000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000D7C3B9EDE0CBBAE3D29C75AACB9165A3CB91
+ 65A3CB9165A3CE9B75AC897BBBEB897BBBEBCE9B75ACCB9165A3CB9165A3CB91
+ 65A3CB9367A3DAC1B0D49389BFF58380CDFFD6D6F3FFFEF8F4FFF5CDAEFFF0B7
+ 8BFFF0B78BFFF3C49FFF8B8BE5FF8B8BE5FFF3C49FFFF0B78BFFF0B78BFFF2C0
+ 9AFFD9CDDDFF8A8ADCFFCEC6D6FFDDB495EDA9A5DEFFA1A1E3FFF9F9FDFFFAE5
+ D5FFF1BC93FFF3C49FFF8B8BE5FF8B8BE5FFF3C49FFFF0B78BFFF4D3BBFFA9A8
+ E3FFA2A2E3FFFBF9FBFFE5CAB3F3D49A6EE5F1BB91FFDBC7CEFF8B8BDCFFD6D6
+ F3FFFEF8F4FFF6D5BCFF8B8BE5FF8B8BE5FFF4CBACFFE2D5DDFF8989DCFFD5D5
+ F2FFFCF0E7FFF2C39EFFD49A6EE5D9A882EAF3C5A2FFF3C5A2FFF3D3BAFFA8A5
+ DFFFC0C0ECFFFFFFFFFF8B8BE5FF8B8BE5FFD5D4F0FF9B9BE1FFF8F6FBFFF9E1
+ CEFFF3C6A4FFF3C5A2FFD9A882EA7570CDFE8C8CE6FF8C8CE6FF8C8CE6FF8C8C
+ E6FF8C8CE6FF8C8CE6FF8383E8FF8383E8FF8C8CE6FF8C8CE6FF8C8CE6FF8C8C
+ E6FF8C8CE6FF8C8CE6FF7570CDFE7570CDFE8C8CE6FF8C8CE6FF8C8CE6FF8C8C
+ E6FF8C8CE6FF8C8CE6FF8383E8FF8383E8FF8C8CE6FF8C8CE6FF8C8CE6FF8C8C
+ E6FF8C8CE6FF8C8CE6FF7570CDFED9A882EAF3C5A2FFF3C7A5FFF9E5D5FFF8F7
+ FCFF9B9BE1FFD5D4EFFF8B8BE5FF8B8BE5FFFDF4EEFFFCFCFEFFA6A6E4FFBEB7
+ DDFFF5CDAFFFF3C5A2FFD9A882EAD49A6EE5F3C7A4FFFDF3ECFFD5D5F2FF8989
+ DCFFE1D2D9FFF3C9A9FF8B8BE5FF8B8BE5FFF3C5A0FFF7D8C0FFFEFCFBFFB8B8
+ EAFF908FDCFFECCCBDFFD49A6FE5E7CFBBF5FBFAFDFFA2A2E3FFA9A8E2FFF4D1
+ B6FFF0B78BFFF3C49FFF8B8BE5FF8B8BE5FFF3C49FFFF0B78BFFF2C29DFFFCEF
+ E5FFE8E8F8FF8888DBFFC1B5CEFBCEC6D6FF8A8ADCFFD9CCDAFFF2BF98FFF0B7
+ 8BFFF0B78BFFF3C49FFF8B8BE5FF8B8BE5FFF3C49FFFF0B78BFFF0B78BFFF0B8
+ 8CFFF7D8C0FFFEFCFBFF9F9AD1FF9389BFF5DAC1AED2CB9367A3CB9165A3CB91
+ 65A3CB9165A3CE9B75AC897BBBEB897BBBEBCE9B75ACCB9165A3CB9165A3CB91
+ 65A3CB9165A3D6AA8AB5DCC7B7EB000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000005656D4E06C6CE2E06C6CE2E06C6CE2E06C6C
+ E2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6C
+ E2E06C6CE2E06C6CE2E05656D4E06C6CDFE58F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE56264DBEE7F7FEEFF7F7FEEFF7F7FEEFF7F7F
+ EEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7F
+ EEFF7F7FEEFF7F7FEEFF6264DBEE79B5EEEE88C4F2FF88C4F2FF88C4F2FF88C4
+ F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4
+ F2FF88C4F2FF88C4F2FF79B5EEEE8ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE58ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE58ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE58ED9FAE5A3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EEFFFFA3EE
+ FFFFA3EEFFFFA3EEFFFF8ED9FAE579B5EEEE88C4F2FF88C4F2FF88C4F2FF88C4
+ F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4F2FF88C4
+ F2FF88C4F2FF88C4F2FF79B5EEEE6264DBEE7F7FEEFF7F7FEEFF7F7FEEFF7F7F
+ EEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7FEEFF7F7F
+ EEFF7F7FEEFF7F7FEEFF6264DBEE6C6CDFE58F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE55656D4E06C6CE2E06C6CE2E06C6CE2E06C6C
+ E2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6CE2E06C6C
+ E2E06C6CE2E06C6CE2E05656D4E0000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000C48A5DE0D49B6FE0D49B6FE0D49B6FE0CF95
+ 69EAD9C4AFEAE8DBCEE0E8DBCEE0E8DBCEE0E8DBCEE0C4B9C6EA6665DCEA6C6C
+ E2E06C6CE2E06C6CE2E05656D4E0D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5D49A6EE5F0B78BFFF0B78BFFF0B78BFFE6AD
+ 80FFEBDACAFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FFD7D0DFFF8282EEFF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE5C48A5DE0D49B6FE0D49B6FE0D49B6FE0CF95
+ 69EAD9C4AFEAE8DBCEE0E8DBCEE0E8DBCEE0E8DBCEE0C4B9C6EA6665DCEA6C6C
+ E2E06C6CE2E06C6CE2E05656D4E0000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000080A86EE08CB57EE08CB57EE08CB57EE08CB3
+ 7FE6A0B688F6E8DBCEE0E8DBCEE0E8DBCEE0E8DBCEE0837FCFF66E6DDFE66C6C
+ E2E06C6CE2E06C6CE2E05656D4E08BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE58BB47DE59EC999FF9EC999FF9EC999FF9EC9
+ 99FFADC39BFFFFFAF2FFFFFAF2FFFFFAF2FFFFFAF2FF9491DDFF8F8FF7FF8F8F
+ F7FF8F8FF7FF8F8FF7FF6C6CDFE580A86EE08CB57EE08CB57EE08CB57EE08CB3
+ 7FE6A0B688F6E8DBCEE0E8DBCEE0E8DBCEE0E8DBCEE0837FCFF66E6DDFE66C6C
+ E2E06C6CE2E06C6CE2E05656D4E0000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000000000000000003F3FF1454242
+ E5FF3030EF410000000000000000000000003F3FF1454141DEFF2F2FE7430000
+ 00000000000000000000000000000000000000000000000000004242E5FF3D3D
+ E9FF3838E7FF2929EF40000000003939F0434040E5FF3838DBFF3535D2FF0000
+ 00000000000000000000000000000000000000000000000000003030EF413838
+ E7FF3232EBFF3333ECFF2B2BEF803C3CE7FF3636DEFF2F2FD4FF2525D7450000
+ 0000000000000000000000000000000000000000000000000000000000002929
+ EF403333ECFF2F2FEDFF3030ECFF3131E5FF2D2DD9FF2626DD43000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00002B2BEF803131ECFF2C2CEBFF2B2BE6FF2929ED8000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000003939
+ F0433C3CE7FF3131E5FF2B2BE6FF2A2AE8FF2A2AE3FF2929EF40000000000000
+ 00000000000000000000000000000000000000000000000000003F3FF1454040
+ E5FF3636DEFF2D2DD9FF2929ED802A2AE3FF2B2BE5FF2E2EDDFF2828E8410000
+ 00000000000000000000000000000000000000000000000000004141DEFF3838
+ DBFF2F2FD4FF2626DD43000000002929EF402E2EDDFF2C2CD8FF2F2FD1FF0000
+ 00000000000000000000000000000000000000000000000000002F2FE7433535
+ D2FF2525D7450000000000000000000000002828E8412F2FD1FF2525D7450000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000
+ }
+ end
+ object DSSomeData: TDataSource
+ DataSet = SomeData
+ left = 183
+ top = 184
+ end
+ object DSCities: TDataSource
+ DataSet = Cities
+ left = 264
+ top = 184
+ end
+end
diff --git a/components/jvcllaz/examples/JvDBLookup/main.pas b/components/jvcllaz/examples/JvDBLookup/main.pas
new file mode 100644
index 000000000..61adbe489
--- /dev/null
+++ b/components/jvcllaz/examples/JvDBLookup/main.pas
@@ -0,0 +1,85 @@
+unit main;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, BufDataset, DB, Forms, Controls, Graphics, Dialogs,
+ DBGrids, JvDBLookup, ExtCtrls, DBCtrls;
+
+type
+
+ { TForm1 }
+
+ TForm1 = class(TForm)
+ Cities: TBufDataset;
+ DBEdit1: TDBEdit;
+ DBGrid1: TDBGrid;
+ DSCities: TDataSource;
+ DSSomeData: TDataSource;
+ ImageList1: TImageList;
+ JvDBLookupCombo1: TJvDBLookupCombo;
+ JvDBLookupList1: TJvDBLookupList;
+ SomeData: TBufDataset;
+ procedure FormShow(Sender: TObject);
+ procedure JvDBLookupList1GetImageIndex(Sender: TObject; IsEmpty: Boolean;
+ var ImageIndex: Integer; var TextMargin: Integer);
+ private
+
+ public
+ Image: TImage;
+ end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.lfm}
+
+const
+ ICON_DE = 0;
+ ICON_UK = 1;
+ ICON_ES = 2;
+ ICON_FR = 3;
+ ICON_IT = 4;
+
+{ TForm1 }
+
+procedure TForm1.FormShow(Sender: TObject);
+begin
+ SomeData.CreateDataset;
+ SomeData.Open;
+ Cities.CreateDataset;
+ Cities.Open;
+ Cities.AppendRecord([ 1, 'Paris', 'France', ICON_FR]);
+ Cities.AppendRecord([ 2, 'Marseilles', 'France', ICON_FR]);
+ Cities.AppendRecord([ 3, 'London', 'United Kingdom', ICON_UK]);
+ Cities.AppendRecord([ 4, 'Oxford', 'United Kingdom', ICON_UK]);
+ Cities.AppendRecord([ 5, 'Lyon', 'France', ICON_FR]);
+ Cities.AppendRecord([ 6, 'Berlin', 'Germany', ICON_DE]);
+ Cities.AppendRecord([ 7, 'Hamburg', 'Germany', ICON_DE]);
+ Cities.AppendRecord([ 8, 'Munich', 'Germany', ICON_DE]);
+ Cities.AppendRecord([ 9, 'Frankfurt', 'Germany', ICON_DE]);
+ Cities.AppendRecord([10, 'Rome', 'Italy', ICON_IT]);
+ Cities.AppendRecord([11, 'Venice', 'Italy', ICON_IT]);
+ Cities.AppendRecord([12, 'Madrid', 'Spain', ICON_ES]);
+ Cities.AppendRecord([13, 'Barcelona', 'Spain', ICON_ES]);
+ Cities.FieldByName('NAME').DisplayWidth := 10;
+ Cities.FieldByName('COUNTRY').DisplayWidth := 10;
+ SomeData.Append;
+end;
+
+procedure TForm1.JvDBLookupList1GetImageIndex(Sender: TObject;
+ IsEmpty: Boolean; var ImageIndex: Integer; var TextMargin: Integer);
+begin
+ if IsEmpty then
+ ImageIndex := 5
+ else
+ ImageIndex := Cities.FieldByName('FLAG').AsInteger;
+ TextMargin := ImageList1.Width + 2;
+end;
+
+end.
+
diff --git a/components/jvcllaz/packages/JvDBLazR.lpk b/components/jvcllaz/packages/JvDBLazR.lpk
index 1a13cd9c2..44b4e4630 100644
--- a/components/jvcllaz/packages/JvDBLazR.lpk
+++ b/components/jvcllaz/packages/JvDBLazR.lpk
@@ -19,7 +19,7 @@
"/>
-
+
@@ -36,6 +36,14 @@
+
+
+
+
+
+
+
+
diff --git a/components/jvcllaz/resource/jvdbreg.res b/components/jvcllaz/resource/jvdbreg.res
index c1deb5bb5..3a52074e1 100644
Binary files a/components/jvcllaz/resource/jvdbreg.res and b/components/jvcllaz/resource/jvdbreg.res differ
diff --git a/components/jvcllaz/run/JvCore/JvTypes.pas b/components/jvcllaz/run/JvCore/JvTypes.pas
index cc8db6584..9d1c05573 100644
--- a/components/jvcllaz/run/JvCore/JvTypes.pas
+++ b/components/jvcllaz/run/JvCore/JvTypes.pas
@@ -339,6 +339,7 @@ type
{**** string handling routines}
TSetOfChar = TSysCharSet;
TCharSet = TSysCharSet;
+ ***********)
TDateOrder = (doMDY, doDMY, doYMD);
TDayOfWeekName = (Sun, Mon, Tue, Wed, Thu, Fri, Sat);
@@ -350,6 +351,7 @@ const
CenturyOffset: Byte = 60;
NullDate: TDateTime = 0; {-693594}
+(*********** NOT CONVERTED
type
// JvDriveCtrls / JvLookOut
TJvImageSize = (isSmall, isLarge);
diff --git a/components/jvcllaz/run/JvDB/jvdblookup.pas b/components/jvcllaz/run/JvDB/jvdblookup.pas
new file mode 100644
index 000000000..ee0fc7a0a
--- /dev/null
+++ b/components/jvcllaz/run/JvDB/jvdblookup.pas
@@ -0,0 +1,4071 @@
+{-----------------------------------------------------------------------------
+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: JvLookup.PAS, released on 2002-07-04.
+
+The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
+Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
+Copyright (c) 2001,2002 SGB Software
+All Rights Reserved.
+
+Contributor(s):
+ Polaris Software
+
+Lazarus port: Michał Gawrycki
+
+Copyright (c) 1995,1997 Borland International
+Portions copyright (c) 1995, 1996 AO ROSNO
+Portions copyright (c) 1997, 1998 Master-Bank
+
+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 JvDBLookup;
+
+{.$I jvcl.inc}
+
+interface
+
+uses
+ Variants, Classes, Graphics, Controls, Forms, DB, DBCtrls,
+ LMessages, LCLType, LCLIntf, LCLProc, EditBtn, Themes,
+ JvThemes, JvDBUtils;
+
+const
+ // (rom) renamed
+ DefFieldsDelimiter = ',';
+
+type
+ TCloseUpEvent = procedure(Sender: TObject; Accept: Boolean) of object;
+
+ TLookupListStyle = (lsFixed, lsDelimited);
+ TJvLookupControl = class;
+ TGetImageEvent = procedure(Sender: TObject; IsEmpty: Boolean;
+ var Graphic: TGraphic; var TextMargin: Integer) of object;
+ TGetImageIndexEvent = procedure(Sender: TObject; IsEmpty: Boolean;
+ var ImageIndex: Integer; var TextMargin: Integer) of object;
+
+ TJvDataSourceLink = class(TJvDataLink)
+ private
+ FDataControl: TJvLookupControl;
+ protected
+ procedure ActiveChanged; override;
+ procedure LayoutChanged; override;
+ procedure FocusControl(const Field: TField); override;
+ procedure RecordChanged(Field: TField); override;
+ procedure UpdateData; override;
+ end;
+
+ TJvLookupSourceLinkMethod = procedure of object;
+
+ TLookupSourceLink = class(TDataLink)
+ private
+ FDataControl: TJvLookupControl;
+ protected
+ procedure ActiveChanged; override;
+ procedure LayoutChanged; override;
+ procedure DataSetChanged; override;
+ procedure DataSetScrolled(Distance: Integer); override;
+ end;
+
+ { TJvLookupControl }
+
+ TJvLookupControl = class(TCustomControl)
+ private
+ FLookupSource: TDataSource;
+ FDataLink: TJvDataSourceLink;
+ FLookupLink: TLookupSourceLink;
+ FDataFieldName: string;
+ FLookupFieldName: string;
+ FLookupDisplay: string;
+ FDisplayIndex: Integer;
+ FDataField: TField;
+ FMasterField: TField;
+ FKeyField: TField;
+ FDisplayField: TField;
+ FListFields: TList;
+ FOnGetImageIndex: TGetImageIndexEvent;
+ FValue: string;
+ FDisplayValue: string;
+ FDisplayEmpty: string;
+ FSearchText: string;
+ FEmptyValue: string;
+ FEmptyStrIsNull: Boolean;
+ FEmptyItemColor: TColor;
+ FListActive: Boolean;
+ FPopup: Boolean;
+ FFocused: Boolean;
+ FLocate: TJvLocateObject;
+ FIndexSwitch: Boolean;
+ FIgnoreCase: Boolean;
+ FItemHeight: Integer;
+ FFieldsDelimiter: Char;
+ FListStyle: TLookupListStyle;
+ FLookupFormat: string;
+ FOnChange: TNotifyEvent;
+ FOnGetImage: TGetImageEvent;
+ FLookupMode: Boolean;
+ FUseRecordCount: Boolean;
+ FRightTrimmedLookup: Boolean;
+ FImageList: TImageList;
+ procedure CheckNotFixed;
+ procedure SetImageList(AValue: TImageList);
+ procedure SetLookupMode(Value: Boolean);
+ function GetKeyValue: Variant;
+ procedure SetKeyValue(const Value: Variant);
+ function CanModify: Boolean;
+ procedure CheckNotCircular;
+ procedure DataLinkActiveChanged;
+ procedure CheckDataLinkActiveChanged;
+ function GetBorderSize: Integer;
+ function GetField: TField;
+ function GetDataSource: TDataSource;
+ function GetLookupField: string;
+ function GetLookupSource: TDataSource;
+ function GetTextHeight: Integer;
+ function DefaultTextHeight: Integer;
+ function GetItemHeight: Integer;
+ function LocateKey: Boolean;
+ function LocateDisplay: Boolean;
+ function ValueIsEmpty(const S: string): Boolean;
+ function StoreEmpty: Boolean;
+ procedure ProcessSearchKey(Key: Char);
+ procedure UpdateKeyValue;
+ procedure SelectKeyValue(const Value: string);
+ procedure SetDataFieldName(const Value: string);
+ procedure SetDataSource(Value: TDataSource);
+ procedure SetDisplayEmpty(const Value: string);
+ procedure SetEmptyValue(const Value: string);
+ procedure SetEmptyStrIsNull(const Value: Boolean);
+ procedure SetEmptyItemColor(Value: TColor);
+ procedure SetLookupField(const Value: string);
+ procedure SetValueKey(const Value: string);
+ procedure SetValue(const Value: string);
+ procedure SetDisplayValue(const Value: string);
+ procedure SetListStyle(Value: TLookupListStyle); virtual;
+ procedure SetFieldsDelimiter(Value: Char); virtual;
+ procedure SetLookupDisplay(const Value: string);
+ procedure SetLookupFormat(const Value: string);
+ procedure SetLookupSource(Value: TDataSource);
+ procedure SetItemHeight(Value: Integer);
+ procedure SetUseRecordCount(const Value: Boolean);
+ function ItemHeightStored: Boolean;
+ procedure DrawPicture(ACanvas: TCanvas; Rect: TRect; Image: TGraphic);
+ procedure DrawImage(ACanvas: TCanvas; Rect: TRect; ImageIndex: Integer);
+ procedure UpdateDisplayValue;
+ function EmptyRowVisible: Boolean;
+ procedure SetDisplayIndex(const Value: Integer);
+ protected
+ procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS;
+ procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS;
+ function GetReadOnly: Boolean; virtual;
+ procedure SetReadOnly(Value: Boolean); virtual;
+ procedure Change; dynamic;
+ procedure KeyValueChanged; virtual;
+ procedure DisplayValueChanged; virtual;
+ function DoFormatLine: string;
+ procedure DataLinkRecordChanged(Field: TField); virtual;
+ procedure DataLinkUpdateData; virtual;
+ procedure ListLinkActiveChanged; virtual;
+ procedure ListLinkDataChanged; virtual;
+ procedure ListLinkDataSetChanged; virtual;
+ procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+ function GetPicture(Current, Empty: Boolean; var TextMargin: Integer): TGraphic; virtual;
+ function GetImageIndex(Current, Empty: Boolean; var TextMargin: Integer): Integer; virtual;
+ procedure UpdateDisplayEmpty(const Value: string); virtual;
+ function SearchText(var AValue: string): Boolean;
+ function GetWindowWidth: Integer;
+ property DataField: string read FDataFieldName write SetDataFieldName;
+ property DataSource: TDataSource read GetDataSource write SetDataSource;
+ property DisplayEmpty: string read FDisplayEmpty write SetDisplayEmpty;
+ property EmptyValue: string read FEmptyValue write SetEmptyValue stored StoreEmpty;
+ property EmptyStrIsNull: Boolean read FEmptyStrIsNull write SetEmptyStrIsNull default True;
+ property EmptyItemColor: TColor read FEmptyItemColor write SetEmptyItemColor default clWindow;
+ property IgnoreCase: Boolean read FIgnoreCase write FIgnoreCase default True;
+ property ImageList: TImageList read FImageList write SetImageList;
+ property IndexSwitch: Boolean read FIndexSwitch write FIndexSwitch default True;
+ property ItemHeight: Integer read GetItemHeight write SetItemHeight stored ItemHeightStored;
+ property ListStyle: TLookupListStyle read FListStyle write SetListStyle default lsFixed;
+ property FieldsDelimiter: Char read FFieldsDelimiter write SetFieldsDelimiter default DefFieldsDelimiter;
+ property LookupDisplay: string read FLookupDisplay write SetLookupDisplay;
+ property LookupDisplayIndex: Integer read FDisplayIndex write SetDisplayIndex default 0;
+ property LookupField: string read GetLookupField write SetLookupField;
+ property LookupFormat: string read FLookupFormat write SetLookupFormat;
+ property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
+ property ParentColor default False;
+ property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False;
+ property TabStop default True;
+ property UseRecordCount: Boolean read FUseRecordCount write SetUseRecordCount default False;
+ property Value: string read FValue write SetValue stored False;
+ property DisplayValue: string read FDisplayValue write SetDisplayValue stored False;
+ property KeyValue: Variant read GetKeyValue write SetKeyValue stored False;
+ property RightTrimmedLookup: Boolean read FRightTrimmedLookup write FRightTrimmedLookup default False;
+ procedure SetFieldValue(Field: TField; const AValue: string);
+ property OnChange: TNotifyEvent read FOnChange write FOnChange;
+ property OnGetImage: TGetImageEvent read FOnGetImage write FOnGetImage;
+ property OnGetImageIndex: TGetImageIndexEvent read FOnGetImageIndex write FOnGetImageIndex;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ procedure ClearValue;
+ function Locate(const SearchField: TField; const AValue: string; Exact: Boolean): Boolean;
+ procedure ResetField; virtual;
+ function ExecuteAction(AAction: TBasicAction): Boolean; override;
+ function UpdateAction(AAction: TBasicAction): Boolean; override;
+ function UseRightToLeftAlignment: Boolean; override;
+ function GetDefaultColor(const DefaultColorType: TDefaultColorType): TColor; override;
+ property Field: TField read GetField;
+ end;
+
+ { TJvDBLookupList }
+
+ TJvDBLookupList = class(TJvLookupControl)
+ private
+ FDisableChangeBounds: Boolean;
+ FRecordIndex: Integer;
+ FRecordCount: Integer;
+ FRowCount: Integer;
+ FKeySelected: Boolean;
+ FTracking: Boolean;
+ FTimerActive: Boolean;
+ FLockPosition: Boolean;
+ FSelectEmpty: Boolean;
+ FMousePos: Integer;
+ function GetKeyIndex: Integer;
+ procedure ListDataChanged;
+ procedure SelectCurrent;
+ procedure SelectItemAt(X, Y: Integer);
+ procedure SetRowCount(AValue: Integer);
+ procedure StopTimer;
+ procedure StopTracking;
+ procedure TimerScroll;
+ procedure UpdateScrollBar;
+ procedure UpdateBufferCount(Rows: Integer);
+ procedure WMCancelMode(var Msg: TLMessage); message LM_CANCELMODE;
+ procedure WMNCHitTest(var Msg: TLMNCHitTest); message LM_NCHITTEST;
+ procedure WMTimer(var Msg: TLMessage); message LM_TIMER;
+ procedure WMVScroll(var Msg: TLMVScroll); message LM_VSCROLL;
+ protected
+ procedure FontChanged(Sender: TObject); override;
+ procedure CreateParams(var Params: TCreateParams); override;
+ procedure CreateWnd; override;
+ procedure KeyValueChanged; override;
+ procedure DisplayValueChanged; override;
+ procedure ListLinkActiveChanged; override;
+ procedure ListLinkDataChanged; override;
+ procedure KeyDown(var Key: Word; Shift: TShiftState); override;
+ procedure KeyPress(var Key: Char); override;
+ procedure Loaded; override;
+ procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer); override;
+ procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
+ procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer); override;
+ procedure Paint; override;
+ procedure UpdateDisplayEmpty(const AValue: string); override;
+ function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
+ function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
+ procedure ChangeBounds(ALeft, ATop, AWidth, AHeight: integer;
+ KeepBase: boolean); override;
+ procedure CalculatePreferredSize(var PreferredWidth,
+ PreferredHeight: integer; WithThemeSpace: Boolean); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
+ procedure DrawItemText(ACanvas: TCanvas; Rect: TRect;
+ Selected, IsEmpty: Boolean); virtual;
+ property RowCount: Integer read FRowCount write SetRowCount stored False;
+ property DisplayValue;
+ property Value;
+ property KeyValue;
+ published
+ property Align;
+ property AutoSize;
+ property BorderSpacing;
+ property BorderStyle default bsSingle;
+ property Color;
+ property DataField;
+ property DataSource;
+ property DisplayEmpty;
+ property DragCursor;
+ property DragMode;
+ property EmptyItemColor;
+ property EmptyValue;
+ property EmptyStrIsNull;
+ property Enabled;
+ property FieldsDelimiter;
+ property Font;
+ property IgnoreCase;
+ property Anchors;
+ property BiDiMode;
+ property Constraints;
+ property DragKind;
+ property ParentBiDiMode;
+ property ImageList;
+ property IndexSwitch;
+ property ItemHeight;
+ property ListStyle;
+ property LookupField;
+ property LookupDisplay;
+ property LookupDisplayIndex;
+ property LookupFormat;
+ property LookupSource;
+ property ParentColor;
+ property ParentFont;
+ property ParentShowHint;
+ property PopupMenu;
+ property ReadOnly;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property Visible;
+ property UseRecordCount;
+ property OnClick;
+ property OnDblClick;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnGetImage;
+ property OnGetImageIndex;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnStartDrag;
+ property OnContextPopup;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnEndDock;
+ property OnStartDock;
+ end;
+
+ //TJvPopupDataListWindow = class;
+
+ TJvPopupDataList = class(TJvDBLookupList)
+ private
+ FCombo: TJvLookupControl;
+ procedure CMHintShow(var Msg: TLMessage); message CM_HINTSHOW;
+ protected
+ procedure Click; override;
+ procedure KeyPress(var Key: Char); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ end;
+
+ { TJvPopupDataListForm }
+
+ TJvPopupDataListForm = class(TForm)
+ private
+ procedure AppDeactivate(Sender: TObject);
+ protected
+ FCombo: TJvLookupControl;
+ FList: TJvPopupDataList;
+ procedure Deactivate; override;
+ procedure KeyPress(var Key: char); override;
+ procedure KeyDown(var Key: Word; Shift: TShiftState); override;
+ procedure DoShow; override;
+ procedure DoClose(var CloseAction: TCloseAction); override;
+ public
+ constructor CreateNew(AOwner: TComponent; Num: Integer = 0); override;
+ end;
+
+ { TJvDBLookupCombo }
+
+ TJvDBLookupCombo = class(TJvLookupControl, IJvDataControl)
+ private
+ FDataListForm: TJvPopupDataListForm;
+ FButtonWidth: Integer;
+ FDropDownCount: Integer;
+ FDropDownWidth: Integer;
+ FDropDownAlign: TDropDownAlign;
+ FEscapeKeyReset: Boolean;
+ FDeleteKeyClear: Boolean;
+ FListVisible: Boolean;
+ FPressed: Boolean;
+ FTracking: Boolean;
+ FAlignment: TAlignment;
+ FSelImage: TPicture;
+ FSelImageIndex: Integer;
+ FSelMargin: Integer;
+ FSelMarginImg: Integer;
+ FDisplayValues: TStringList;
+ FDisplayAllFields: Boolean;
+ FTabSelects: Boolean;
+ FOnDropDown: TNotifyEvent;
+ FOnCloseUp: TNotifyEvent;
+ FLastValue: Variant;
+ FInListDataSetChanged: Boolean;
+ FMouseOverButton: Boolean;
+ FMouseOver: Boolean;
+ FWhenClosed: Int64;
+ procedure ListMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+ procedure StopTracking;
+ procedure TrackButton(X, Y: Integer);
+ function GetMinHeight: Integer;
+ function GetText: string;
+ procedure InvalidateText;
+ procedure UpdateCurrentImage;
+ procedure PaintDisplayValues(ACanvas: TCanvas; R: TRect; ALeft: Integer);
+ procedure SetFieldsDelimiter(AValue: Char); override;
+ procedure SetListStyle(AValue: TLookupListStyle); override;
+ function GetDisplayAllFields: Boolean;
+ procedure SetDisplayAllFields(AValue: Boolean);
+ function GetDisplayValues(Index: Integer): string;
+ procedure CNKeyDown(var Msg: TLMKeyDown); message CN_KEYDOWN;
+ procedure CMGetDataLink(var Msg: TLMessage); message CM_GETDATALINK;
+ procedure WMCancelMode(var Msg: TLMessage); message LM_CANCELMODE;
+ procedure WMSetCursor(var Msg: TLMSetCursor); message LM_SETCURSOR;
+ procedure CMBiDiModeChanged(var Msg: TLMessage); message CM_BIDIMODECHANGED;
+ procedure CMHintShow(var Msg: TLMessage); message CM_HINTSHOW;
+ procedure WMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
+ procedure ReadEscapeClear(Reader: TReader);
+ procedure SetMouseOverButton(AValue: Boolean);
+ protected
+ procedure CreateWnd; override;
+ procedure SetReadOnly(AValue: Boolean); override;
+ function GetDropDownButtonRect: TRect;
+ procedure InvalidateFrame;
+ procedure InvalidateDropDownButton;
+ function GetDataLink: TDataLink; virtual;
+ procedure BoundsChanged; override;
+ procedure EnabledChanged; override;
+ procedure FontChanged(Sender: TObject); override;
+ procedure MouseEnter; override;
+ procedure MouseLeave; override;
+ procedure DoEnter; override;
+ procedure Click; override;
+ function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
+ function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
+ function GetPicture(Current, Empty: Boolean; var TextMargin: Integer): TGraphic; override;
+ function GetImageIndex(Current, Empty: Boolean; var TextMargin: Integer
+ ): Integer; override;
+ procedure UpdateFieldText;
+ procedure KeyValueChanged; override;
+ procedure DisplayValueChanged; override;
+ procedure ListLinkActiveChanged; override;
+ procedure ListLinkDataChanged; override;
+ procedure ListLinkDataSetChanged; override;
+ procedure DataLinkRecordChanged(AField: TField); override;
+ procedure DataLinkUpdateData; override;
+ procedure Paint; override;
+ procedure KeyDown(var Key: Word; Shift: TShiftState); override;
+ procedure KeyPress(var Key: Char); override;
+ procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
+ procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
+ procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
+ procedure UpdateDisplayEmpty(const AValue: string); override;
+ procedure DefineProperties(Filer: TFiler); override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ procedure CloseUp(Accept: Boolean); dynamic;
+ procedure DropDown; virtual;
+ procedure ResetField; override;
+ property IsDropDown: Boolean read FListVisible;
+ property ListVisible: Boolean read FListVisible;
+ property Text: string read GetText;
+ property DisplayValue;
+ property DisplayValues[Index: Integer]: string read GetDisplayValues;
+ property Value;
+ property KeyValue;
+ published
+ property Align;
+ property BorderSpacing;
+ property BorderStyle default bsSingle;
+ property DropDownAlign: TDropDownAlign read FDropDownAlign write FDropDownAlign default daLeft;
+ property DropDownCount: Integer read FDropDownCount write FDropDownCount default 8;
+ property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
+ property EscapeKeyReset: Boolean read FEscapeKeyReset write FEscapeKeyReset default True;
+ property DeleteKeyClear: Boolean read FDeleteKeyClear write FDeleteKeyClear default True;
+ property DisplayAllFields: Boolean read GetDisplayAllFields write SetDisplayAllFields default False;
+ property TabSelects : Boolean read FTabSelects write FTabSelects default False;
+ property Color;
+ property DataField;
+ property DataSource;
+ property DisplayEmpty;
+ property DragCursor;
+ property DragMode;
+ property EmptyValue;
+ property EmptyStrIsNull;
+ property EmptyItemColor;
+ property Enabled;
+ property FieldsDelimiter;
+ property Font;
+ property IgnoreCase;
+ property Anchors;
+ property BiDiMode;
+ property Constraints;
+ property DragKind;
+ property ParentBiDiMode;
+ property ImageList;
+ property IndexSwitch;
+ property ItemHeight;
+ property ListStyle;
+ property LookupField;
+ property LookupDisplay;
+ property LookupDisplayIndex;
+ property LookupFormat;
+ property LookupSource;
+ property ParentColor;
+ property ParentFont;
+ property ParentShowHint;
+ property PopupMenu;
+ property ReadOnly;
+ property RightTrimmedLookup;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property UseRecordCount;
+ property Visible;
+ property OnChange;
+ property OnClick;
+ property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
+ property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnGetImage;
+ property OnGetImageIndex;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnMouseWheelDown;
+ property OnMouseWheelUp;
+ property OnStartDrag;
+ property OnContextPopup;
+ property OnEndDock;
+ property OnStartDock;
+ end;
+
+(* TJvPopupDataWindow = class(TJvPopupDataList)
+ private
+ FEditor: TWinControl;
+ FCloseUp: TCloseUpEvent;
+ protected
+ procedure InvalidateEditor;
+ procedure Click; override;
+ procedure DisplayValueChanged; override;
+ function GetPicture(Current, Empty: Boolean; var TextMargin: Integer): TGraphic; override;
+ procedure KeyPress(var Key: Char); override;
+ procedure PopupMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+ procedure CloseUp(Accept: Boolean); virtual;
+ public
+ constructor Create(AOwner: TComponent); override;
+ procedure Hide;
+ procedure Show(Origin: TPoint);
+ property OnCloseUp: TCloseUpEvent read FCloseUp write FCloseUp;
+ end;
+
+ TJvDBLookupEdit = class(TCustomEditButton)
+ private
+ FChanging: Boolean;
+ FIgnoreChange: Boolean;
+ FDropDownCount: Integer;
+ FDropDownWidth: Integer;
+ FPopupOnlyLocate: Boolean;
+ FOnCloseUp: TNotifyEvent;
+ FOnDropDown: TNotifyEvent;
+ FBeforePopupValue: Variant;
+ function GetListStyle: TLookupListStyle;
+ procedure SetListStyle(Value: TLookupListStyle);
+ function GetFieldsDelimiter: Char;
+ procedure SetFieldsDelimiter(Value: Char);
+ function GetLookupDisplay: string;
+ procedure SetLookupDisplay(const Value: string);
+ function GetDisplayIndex: Integer;
+ procedure SetDisplayIndex(Value: Integer);
+ function GetLookupField: string;
+ procedure SetLookupField(const Value: string);
+ function GetLookupSource: TDataSource;
+ procedure SetLookupSource(Value: TDataSource);
+ procedure SetDropDownCount(Value: Integer);
+ function GetLookupValue: string;
+ procedure SetLookupValue(const Value: string);
+ function GetOnGetImage: TGetImageEvent;
+ procedure SetOnGetImage(Value: TGetImageEvent);
+ function GetUseRecordCount: Boolean;
+ procedure SetUseRecordCount(const Value: Boolean);
+ protected
+ procedure Change; override;
+ procedure KeyDown(var Key: Word; Shift: TShiftState); override;
+ procedure KeyPress(var Key: Char); override;
+ procedure ShowPopup(Origin: TPoint); override;
+ procedure HidePopup; override;
+ procedure PopupChange; override;
+ procedure PopupDropDown(DisableEdit: Boolean); override;
+ function AcceptPopup(var Value: Variant): Boolean; override;
+ procedure SetPopupValue(const Value: Variant); override;
+ function GetPopupValue: Variant; override;
+ public
+ constructor Create(AOwner: TComponent); override;
+ destructor Destroy; override;
+ property LookupValue: string read GetLookupValue write SetLookupValue;
+ published
+ property DropDownCount: Integer read FDropDownCount write SetDropDownCount default 8;
+ property DropDownWidth: Integer read FDropDownWidth write FDropDownWidth default 0;
+ property ListStyle: TLookupListStyle read GetListStyle write SetListStyle default lsFixed;
+ property FieldsDelimiter: Char read GetFieldsDelimiter write SetFieldsDelimiter default DefFieldsDelimiter;
+ property LookupDisplay: string read GetLookupDisplay write SetLookupDisplay;
+ property LookupDisplayIndex: Integer read GetDisplayIndex write SetDisplayIndex default 0;
+ property LookupField: string read GetLookupField write SetLookupField;
+ property LookupSource: TDataSource read GetLookupSource write SetLookupSource;
+ property PopupOnlyLocate: Boolean read FPopupOnlyLocate write FPopupOnlyLocate default True;
+ property Alignment;
+ property AutoSelect;
+ property AutoSize;
+ property BorderStyle;
+ property ButtonHint;
+ property CharCase;
+ //property ClickKey;
+ property Color;
+ property DirectInput;
+ property DragCursor;
+ property DragMode;
+ property EditMask;
+ property Enabled;
+ property Font;
+ //property BevelEdges;
+ //property BevelInner;
+ //property BevelKind default bkNone;
+ //property BevelOuter;
+ property Flat;
+ //property ParentFlat;
+ property HideSelection;
+ property Anchors;
+ property BiDiMode;
+ property Constraints;
+ property DragKind;
+ property ParentBiDiMode;
+ //property ImeMode;
+ //property ImeName;
+ property MaxLength;
+ //property OEMConvert;
+ property ParentColor;
+ property ParentFont;
+ property ParentShowHint;
+ //property PopupAlign;
+ property PopupMenu;
+ property ReadOnly;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property Text;
+ property UseRecordCount: Boolean read GetUseRecordCount write SetUseRecordCount default False;
+ property Visible;
+ property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
+ property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
+ property OnGetImage: TGetImageEvent read GetOnGetImage write SetOnGetImage;
+ property OnButtonClick;
+ property OnChange;
+ property OnClick;
+ property OnDblClick;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnKeyDown;
+ property OnKeyPress;
+ property OnKeyUp;
+ property OnMouseDown;
+ property OnMouseMove;
+ property OnMouseUp;
+ property OnStartDrag;
+ property OnContextPopup;
+ property OnEndDock;
+ property OnStartDock;
+
+ {$IFDEF COMPILER14_UP}
+ property Touch;
+ {$ENDIF COMPILER14_UP}
+ property TextHint;
+ end;
+*)
+
+implementation
+
+uses
+ DBConst, SysUtils, Math, {MultiMon,}
+ {JclSysInfo,}
+ JvJCLUtils, JvJVCLUtils, JvTypes, JvConsts, JvResources{, JclSysUtils};
+
+procedure CheckLookupFormat(const AFormat: string);
+ { AFormat is passed to a Format function, but the only allowed
+ format specifiers are %s, %S and %% }
+var
+ P: PChar;
+begin
+ P := StrScan(PChar(AFormat), '%');
+ while Assigned(P) do
+ begin
+ Inc(P);
+ if P^ = #0 then
+ raise EJVCLException.CreateRes(@RsEInvalidFormatNotAllowed)
+ else
+ if not CharInSet(P^, ['%', 's', 'S']) then
+ raise EJVCLException.CreateResFmt(@RsEInvalidFormatsNotAllowed,
+ [QuotedStr('%' + P^)]);
+ P := StrScan(P + 2, '%');
+ end;
+end;
+
+function GetSpecifierCount(const AFormat: string): Integer;
+ { GetSpecifierCount counts the nr of format specifiers in AFormat }
+var
+ P: PChar;
+begin
+ Result := 0;
+ P := StrScan(PChar(AFormat), '%');
+ while Assigned(P) do
+ begin
+ Inc(P);
+ if P^ = #0 then
+ Exit
+ else
+ if CharInSet(P^, ['s', 'S']) then
+ Inc(Result);
+ P := StrScan(P + 2, '%');
+ end;
+end;
+
+//=== { TJvDataSourceLink } ==================================================
+
+procedure TJvDataSourceLink.ActiveChanged;
+begin
+ if FDataControl <> nil then
+ FDataControl.DataLinkActiveChanged;
+end;
+
+procedure TJvDataSourceLink.LayoutChanged;
+begin
+ if FDataControl <> nil then
+ FDataControl.CheckDataLinkActiveChanged;
+end;
+
+procedure TJvDataSourceLink.RecordChanged(Field: TField);
+begin
+ if FDataControl <> nil then
+ FDataControl.DataLinkRecordChanged(Field);
+end;
+
+procedure TJvDataSourceLink.UpdateData;
+begin
+ if FDataControl <> nil then
+ FDataControl.DataLinkUpdateData;
+end;
+
+procedure TJvDataSourceLink.FocusControl(const Field: TField);
+begin
+ if (Field <> nil) and (FDataControl <> nil) and
+ (Field = FDataControl.FDataField) and FDataControl.CanFocus then
+ FDataControl.SetFocus;
+end;
+
+//=== { TLookupSourceLink } ==================================================
+
+procedure TLookupSourceLink.ActiveChanged;
+begin
+ if FDataControl <> nil then
+ FDataControl.ListLinkActiveChanged;
+end;
+
+procedure TLookupSourceLink.LayoutChanged;
+begin
+ if FDataControl <> nil then
+ FDataControl.ListLinkActiveChanged;
+end;
+
+procedure TLookupSourceLink.DataSetChanged;
+begin
+ if FDataControl <> nil then
+ FDataControl.ListLinkDataSetChanged;
+end;
+
+procedure TLookupSourceLink.DataSetScrolled(Distance: Integer);
+begin
+ if FDataControl <> nil then
+ FDataControl.ListLinkDataChanged;
+end;
+
+//=== { TJvLookupControl } ===================================================
+
+var
+ SearchTickCount: Int64 = 0;
+
+constructor TJvLookupControl.Create(AOwner: TComponent);
+const
+ LookupStyle = [csOpaque];
+begin
+ inherited Create(AOwner);
+ ControlStyle := LookupStyle;
+ IncludeThemeStyle(Self, [csNeedsBorderPaint]);
+
+ ParentColor := False;
+ TabStop := True;
+ FFieldsDelimiter := DefFieldsDelimiter;
+ FLookupSource := TDataSource.Create(Self);
+ FDataLink := TJvDataSourceLink.Create;
+ FDataLink.FDataControl := Self;
+ FLookupLink := TLookupSourceLink.Create;
+ FLookupLink.FDataControl := Self;
+ FListFields := TList.Create;
+ FEmptyValue := '';
+ FEmptyStrIsNull := True;
+ FEmptyItemColor := clWindow;
+ FValue := FEmptyValue;
+ FLocate := CreateLocate(nil);
+ FIndexSwitch := True;
+ FIgnoreCase := True;
+ FUseRecordCount := False;
+end;
+
+destructor TJvLookupControl.Destroy;
+begin
+ FListFields.Free;
+ FListFields := nil;
+ if FLookupLink <> nil then
+ FLookupLink.FDataControl := nil;
+ FLookupLink.Free;
+ FLookupLink := nil;
+ if FDataLink <> nil then
+ FDataLink.FDataControl := nil;
+ FDataLink.Free;
+ FDataLink := nil;
+ FLocate.Free;
+ FLocate := nil;
+ inherited Destroy;
+end;
+
+function TJvLookupControl.CanModify: Boolean;
+begin
+ Result := FListActive and not ReadOnly and ((FDataLink.DataSource = nil) or
+ (FMasterField <> nil) and FMasterField.CanModify);
+end;
+
+procedure TJvLookupControl.Change;
+begin
+ if Assigned(FOnChange) then
+ FOnChange(Self);
+end;
+
+function TJvLookupControl.ValueIsEmpty(const S: string): Boolean;
+begin
+ Result := (S = FEmptyValue);
+end;
+
+function TJvLookupControl.StoreEmpty: Boolean;
+begin
+ Result := (FEmptyValue <> '');
+end;
+
+procedure TJvLookupControl.CheckNotFixed;
+begin
+ if FLookupMode then
+ _DBError('SPropDefByLookup');
+ if FDataLink.DataSourceFixed then
+ _DBError('SDataSourceFixed');
+end;
+
+procedure TJvLookupControl.SetImageList(AValue: TImageList);
+begin
+ if FImageList = AValue then Exit;
+ FImageList := AValue;
+
+end;
+
+procedure TJvLookupControl.SetLookupMode(Value: Boolean);
+begin
+ if FLookupMode <> Value then
+ if Value then
+ begin
+ FMasterField := FDataField.DataSet.FieldByName(FDataField.KeyFields);
+ FLookupSource.DataSet := FDataField.LookupDataSet;
+ FLookupFieldName := FDataField.LookupKeyFields;
+ FLookupMode := True;
+ FLookupLink.DataSource := FLookupSource;
+ end
+ else
+ begin
+ FLookupLink.DataSource := nil;
+ FLookupMode := False;
+ FLookupFieldName := '';
+ FLookupSource.DataSet := nil;
+ FMasterField := FDataField;
+ end;
+end;
+
+procedure TJvLookupControl.SetUseRecordCount(const Value: Boolean);
+begin
+ if Value <> FUseRecordCount then
+ begin
+ FUseRecordCount := Value;
+ ListLinkActiveChanged;
+ if FListActive then
+ DataLinkRecordChanged(nil);
+ end;
+end;
+
+function TJvLookupControl.GetKeyValue: Variant;
+begin
+ if ValueIsEmpty(Value) then
+ begin
+ if (Value = '') and FEmptyStrIsNull then
+ Result := Null
+ else
+ Result := FEmptyValue;
+ end
+ else
+ Result := Value;
+end;
+
+procedure TJvLookupControl.SetKeyValue(const Value: Variant);
+begin
+ if VarIsNull(Value) or VarIsEmpty(Value) then
+ Self.Value := FEmptyValue
+ else
+ Self.Value := Value;
+end;
+
+procedure TJvLookupControl.CheckNotCircular;
+begin
+ {
+ if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(LookupSource) then
+ _DBError(SCircularDataLink);
+ }
+ if FDataLink.Active and ((DataSource = LookupSource) or
+ (FDataLink.DataSet = FLookupLink.DataSet)) then
+ _DBError(SErrCircularDataSourceReferenceNotAllowed);
+end;
+
+procedure TJvLookupControl.CheckDataLinkActiveChanged;
+var
+ TestField: TField;
+begin
+ if FDataLink.Active and (FDataFieldName <> '') then
+ begin
+ TestField := FDataLink.DataSet.FieldByName(FDataFieldName);
+ if FDataField <> TestField then
+ begin
+ FDataField := nil;
+ FMasterField := nil;
+ CheckNotCircular;
+ FDataField := TestField;
+ FMasterField := FDataField;
+ end;
+ DataLinkRecordChanged(nil);
+ end;
+end;
+
+procedure TJvLookupControl.DataLinkActiveChanged;
+begin
+ FDataField := nil;
+ FMasterField := nil;
+ if FDataLink.Active and (FDataFieldName <> '') then
+ begin
+ CheckNotCircular;
+ FDataField := FDataLink.DataSet.FieldByName(FDataFieldName);
+ FMasterField := FDataField;
+ end;
+ SetLookupMode((FDataField <> nil) and (FDataField.FieldKind = fkLookup));
+ DataLinkRecordChanged(nil);
+end;
+
+procedure TJvLookupControl.DataLinkRecordChanged(Field: TField);
+begin
+ if (Field = nil) or (Field = FMasterField) then
+ begin
+ if (FMasterField <> nil) and FMasterField.DataSet.Active then
+ SetValueKey(FMasterField.AsString)
+ else
+ SetValueKey(FEmptyValue);
+ end;
+end;
+
+procedure TJvLookupControl.DataLinkUpdateData;
+begin
+end;
+
+function TJvLookupControl.ExecuteAction(AAction: TBasicAction): Boolean;
+begin
+ Result := inherited ExecuteAction(AAction) or ((FDataLink <> nil) and
+ FDataLink.ExecuteAction(AAction));
+end;
+
+function TJvLookupControl.UpdateAction(AAction: TBasicAction): Boolean;
+begin
+ Result := inherited UpdateAction(AAction) or ((FDataLink <> nil) and
+ FDataLink.UpdateAction(AAction));
+end;
+
+function TJvLookupControl.UseRightToLeftAlignment: Boolean;
+begin
+ //Result := DBUseRightToLeftAlignment(Self, Field);
+ Result := inherited UseRightToLeftAlignment;
+end;
+
+function TJvLookupControl.GetBorderSize: Integer;
+begin
+ Result := Height - ClientHeight;
+end;
+
+function TJvLookupControl.GetDataSource: TDataSource;
+begin
+ Result := FDataLink.DataSource;
+end;
+
+function TJvLookupControl.GetLookupField: string;
+begin
+ if FLookupMode then
+ Result := ''
+ else
+ Result := FLookupFieldName;
+end;
+
+function TJvLookupControl.GetLookupSource: TDataSource;
+begin
+ if FLookupMode then
+ Result := nil
+ else
+ Result := FLookupLink.DataSource;
+end;
+
+function TJvLookupControl.GetReadOnly: Boolean;
+begin
+ Result := FDataLink.ReadOnly;
+end;
+
+function TJvLookupControl.GetField: TField;
+begin
+ if Assigned(FDataLink) then
+ Result := FDataField
+ else
+ Result := nil;
+end;
+
+// (rom) is this useful for other components? It seems superior.
+
+function TJvLookupControl.DefaultTextHeight: Integer;
+begin
+ //Result := Screen.SystemFont.GetTextHeight('Mg'); //Canvas.TextHeight('Mg');
+ Result := Font.GetTextHeight('Mg');
+end;
+
+function TJvLookupControl.GetTextHeight: Integer;
+begin
+ Result := Max(DefaultTextHeight, FItemHeight);
+end;
+
+procedure TJvLookupControl.KeyValueChanged;
+begin
+end;
+
+procedure TJvLookupControl.DisplayValueChanged;
+begin
+end;
+
+procedure TJvLookupControl.ListLinkActiveChanged;
+var
+ DataSet: TDataSet;
+ ResultField: TField;
+begin
+ FListActive := False;
+ FKeyField := nil;
+ FDisplayField := nil;
+ FListFields.Clear;
+ if FLookupLink.Active and (FLookupFieldName <> '') then
+ begin
+ CheckNotCircular;
+ DataSet := FLookupLink.DataSet;
+ FKeyField := DataSet.FieldByName(FLookupFieldName);
+ DataSet.GetFieldList(FListFields, FLookupDisplay);
+ if FLookupMode then
+ begin
+ ResultField := DataSet.FieldByName(FDataField.LookupResultField);
+ if FListFields.IndexOf(ResultField) < 0 then
+ FListFields.Insert(0, ResultField);
+ FDisplayField := ResultField;
+ end
+ else
+ begin
+ if FListFields.Count = 0 then
+ FListFields.Add(FKeyField);
+ if (FDisplayIndex >= 0) and (FDisplayIndex < FListFields.Count) then
+ FDisplayField := TField(FListFields[FDisplayIndex])
+ else
+ FDisplayField := TField(FListFields[0]);
+ end;
+ { Reset LookupFormat if the number of specifiers > fields count
+ else function Format will raise an error }
+ if GetSpecifierCount(FLookupFormat) > FListFields.Count then
+ FLookupFormat := '';
+
+ FListActive := True;
+ end;
+ FLocate.DataSet := FLookupLink.DataSet;
+end;
+
+procedure TJvLookupControl.ListLinkDataChanged;
+begin
+end;
+
+procedure TJvLookupControl.ListLinkDataSetChanged;
+begin
+ ListLinkDataChanged;
+end;
+
+function TJvLookupControl.LocateDisplay: Boolean;
+begin
+ Result := False;
+ try
+ Result := Locate(FDisplayField, FDisplayValue, True);
+ except
+ end;
+end;
+
+function TJvLookupControl.LocateKey: Boolean;
+begin
+ Result := False;
+ try
+ Result := not ValueIsEmpty(FValue) and Locate(FKeyField, FValue, True);
+ except
+ end;
+end;
+
+procedure TJvLookupControl.Notification(AComponent: TComponent;
+ Operation: TOperation);
+begin
+ inherited Notification(AComponent, Operation);
+ if Operation = opRemove then
+ begin
+ if (FDataLink <> nil) and (AComponent = DataSource) then
+ DataSource := nil;
+ if (FLookupLink <> nil) and (AComponent = LookupSource) then
+ LookupSource := nil;
+ if AComponent = FMasterField then
+ FMasterField := nil;
+ end;
+end;
+
+function TJvLookupControl.SearchText(var AValue: string): Boolean;
+begin
+ Result := False;
+ if FDisplayField <> nil then
+ if (AValue <> '') and Locate(FDisplayField, AValue, False) then
+ begin
+ SelectKeyValue(FKeyField.AsString);
+ AValue := Copy(FDisplayField.AsString, 1, Length(AValue));
+ Result := True;
+ end
+ else
+ if AValue = '' then
+ begin
+ FLookupLink.DataSet.First;
+ SelectKeyValue(FKeyField.AsString);
+ AValue := '';
+ end;
+end;
+
+procedure TJvLookupControl.ProcessSearchKey(Key: Char);
+var
+ TickCount: Int64;
+ S: string;
+begin
+ S := '';
+ if (FDisplayField <> nil) then
+ case Key of
+ Tab, Esc:
+ FSearchText := '';
+ Backspace, #32..High(Char):
+ if CanModify then
+ begin
+ if not FPopup then
+ begin
+ TickCount := GetTickCount64;
+ if TickCount - SearchTickCount > 2000 then
+ FSearchText := '';
+ SearchTickCount := TickCount;
+ end;
+ if Key = Backspace then
+ S := Copy(FSearchText, 1, Length(FSearchText) - 1)
+ else
+ if Length(FSearchText) < 32 then
+ S := FSearchText + Key;
+ if SearchText(S) or (S = '') then
+ FSearchText := S;
+ end;
+ end;
+end;
+
+procedure TJvLookupControl.ResetField;
+begin
+ if (FDataLink.DataSource = nil) or (FMasterField = nil) or FDataLink.Edit then
+ begin
+ if (FDataLink.DataSource <> nil) and FDataLink.Edit and (FMasterField <> nil) then
+ SetFieldValue(FMasterField, FEmptyValue);
+ FValue := FEmptyValue;
+ FDisplayValue := '';
+ inherited Text := DisplayEmpty;
+ Invalidate;
+ Click;
+ end;
+end;
+
+procedure TJvLookupControl.ClearValue;
+begin
+ SetValueKey(FEmptyValue);
+end;
+
+procedure TJvLookupControl.SelectKeyValue(const Value: string);
+begin
+ if FMasterField <> nil then
+ begin
+ if CanModify and FDataLink.Edit then
+ begin
+ if FDataField = FMasterField then
+ FDataField.DataSet.Edit;
+ SetFieldValue(FMasterField, Value);
+ end
+ else
+ Exit;
+ end;
+ SetValueKey(Value);
+ UpdateDisplayValue;
+ Repaint;
+ Click;
+end;
+
+procedure TJvLookupControl.SetDataFieldName(const Value: string);
+begin
+ if FDataFieldName <> Value then
+ begin
+ FDataFieldName := Value;
+ DataLinkActiveChanged;
+ end;
+end;
+
+procedure TJvLookupControl.SetDataSource(Value: TDataSource);
+begin
+ if FDataLink.DataSource <> nil then
+ FDataLink.DataSource.RemoveFreeNotification(Self);
+ FDataLink.DataSource := Value;
+ if Value <> nil then
+ Value.FreeNotification(Self);
+end;
+
+procedure TJvLookupControl.SetListStyle(Value: TLookupListStyle);
+begin
+ if FListStyle <> Value then
+ begin
+ FListStyle := Value;
+ Invalidate;
+ end;
+end;
+
+procedure TJvLookupControl.SetFieldsDelimiter(Value: Char);
+begin
+ if FFieldsDelimiter <> Value then
+ begin
+ FFieldsDelimiter := Value;
+ if ListStyle = lsDelimited then
+ Invalidate;
+ end;
+end;
+
+procedure TJvLookupControl.SetLookupField(const Value: string);
+begin
+ CheckNotFixed;
+ if FLookupFieldName <> Value then
+ begin
+ FLookupFieldName := Value;
+ ListLinkActiveChanged;
+ if FListActive then
+ DataLinkRecordChanged(nil);
+ end;
+end;
+
+procedure TJvLookupControl.SetDisplayEmpty(const Value: string);
+begin
+ if FDisplayEmpty <> Value then
+ begin
+ UpdateDisplayEmpty(Value);
+ FDisplayEmpty := Value;
+ if not (csReading in ComponentState) then
+ Invalidate;
+ end;
+end;
+
+procedure TJvLookupControl.SetDisplayIndex(const Value: Integer);
+begin
+ if Value <> FDisplayIndex then
+ begin
+ FDisplayIndex := Value;
+ ListLinkActiveChanged;
+ end;
+end;
+
+procedure TJvLookupControl.WMSetFocus(var Message: TLMSetFocus);
+begin
+ FFocused := True;
+ inherited;
+ Invalidate;
+end;
+
+procedure TJvLookupControl.WMKillFocus(var Message: TLMKillFocus);
+begin
+ FFocused := False;
+ inherited;
+ Invalidate;
+end;
+
+procedure TJvLookupControl.SetEmptyValue(const Value: string);
+begin
+ if FEmptyValue <> Value then
+ begin
+ if ValueIsEmpty(FValue) then
+ FValue := Value;
+ FEmptyValue := Value;
+ end;
+end;
+
+procedure TJvLookupControl.SetFieldValue(Field: TField; const AValue: string);
+begin
+ if AValue = FEmptyValue then
+ if (FEmptyValue = '') and FEmptyStrIsNull then
+ Field.Clear
+ else
+ Field.AsString := FEmptyValue
+ else
+ Field.AsString := AValue;
+end;
+
+procedure TJvLookupControl.SetEmptyStrIsNull(const Value: Boolean);
+begin
+ if FEmptyStrIsNull <> Value then
+ begin
+ FEmptyStrIsNull := Value;
+ if CanModify and (FDataLink.DataSource <> nil) and FDataLink.Edit then
+ if FMasterField <> nil then
+ SetFieldValue(FMasterField, FValue)
+ else
+ SetFieldValue(FDataField, FValue);
+ end;
+end;
+
+procedure TJvLookupControl.SetEmptyItemColor(Value: TColor);
+begin
+ if FEmptyItemColor <> Value then
+ begin
+ FEmptyItemColor := Value;
+ if not (csReading in ComponentState) and EmptyRowVisible then
+ Invalidate;
+ end;
+end;
+
+procedure TJvLookupControl.UpdateDisplayEmpty(const Value: string);
+begin
+end;
+
+procedure TJvLookupControl.SetDisplayValue(const Value: string);
+begin
+ if (FDisplayValue <> Value) and CanModify and (FDataLink.DataSource <> nil) and
+ Locate(FDisplayField, Value, True) then
+ begin
+ if FDataLink.Edit then
+ begin
+ // if FMasterField <> nil then FMasterField.AsString := S
+ // else FDataField.AsString := S;
+ if FMasterField <> nil then
+ SetFieldValue(FMasterField, FValue)
+ else
+ SetFieldValue(FDataField, FValue);
+ end;
+ end
+ else
+ if FDisplayValue <> Value then
+ begin
+ FDisplayValue := Value;
+ DisplayValueChanged;
+ Change;
+ end;
+end;
+
+procedure TJvLookupControl.UpdateKeyValue;
+begin
+ if FMasterField <> nil then
+ FValue := FMasterField.AsString
+ else
+ FValue := FEmptyValue;
+ KeyValueChanged;
+end;
+
+procedure TJvLookupControl.SetValueKey(const Value: string);
+begin
+ if FValue <> Value then
+ begin
+ FValue := Value;
+ KeyValueChanged;
+ end;
+end;
+
+procedure TJvLookupControl.SetValue(const Value: string);
+begin
+ if Value <> FValue then
+ begin
+ if CanModify and (FDataLink.DataSource <> nil) and FDataLink.Edit then
+ begin
+ // if FMasterField <> nil then FMasterField.AsString := Value
+ // else FDataField.AsString := Value;
+ if FMasterField <> nil then
+ SetFieldValue(FMasterField, Value)
+ else
+ SetFieldValue(FDataField, Value);
+ end
+ else
+ SetValueKey(Value);
+ Change;
+ end;
+end;
+
+procedure TJvLookupControl.SetLookupDisplay(const Value: string);
+begin
+ if FLookupDisplay <> Value then
+ begin
+ FLookupDisplay := Value;
+ ListLinkActiveChanged;
+ if FListActive then
+ DataLinkRecordChanged(nil);
+ end;
+end;
+
+procedure TJvLookupControl.SetLookupSource(Value: TDataSource);
+begin
+ CheckNotFixed;
+ if FLookupLink.DataSource <> nil then
+ FLookupLink.DataSource.RemoveFreeNotification(Self);
+ FLookupLink.DataSource := Value;
+ if Value <> nil then
+ Value.FreeNotification(Self);
+ if Value <> nil then
+ FLocate.DataSet := Value.DataSet
+ else
+ FLocate.DataSet := nil;
+ if FListActive then
+ DataLinkRecordChanged(nil);
+end;
+
+procedure TJvLookupControl.SetReadOnly(Value: Boolean);
+begin
+ FDataLink.ReadOnly := Value;
+end;
+
+function TJvLookupControl.GetItemHeight: Integer;
+begin
+ Result := Max(GetTextHeight, FItemHeight); //GetTextHeight;
+end;
+
+procedure TJvLookupControl.SetItemHeight(Value: Integer);
+begin
+ if not (csReading in ComponentState) then
+ FItemHeight := Max(DefaultTextHeight, Value)
+ else
+ FItemHeight := Value;
+ Perform(CM_FONTCHANGED, 0, 0);
+end;
+
+function TJvLookupControl.ItemHeightStored: Boolean;
+begin
+ Result := FItemHeight > DefaultTextHeight;
+end;
+
+procedure TJvLookupControl.DrawPicture(ACanvas: TCanvas; Rect: TRect;
+ Image: TGraphic);
+var
+ X, Y, SaveIndex: Integer;
+ //Ico: HICON;
+ //W, H: Integer;
+begin
+ if Image <> nil then
+ begin
+ X := (Rect.Right + Rect.Left - Image.Width) div 2;
+ Y := (Rect.Top + Rect.Bottom - Image.Height) div 2;
+ SaveIndex := SaveDC(ACanvas.Handle);
+ try
+ IntersectClipRect(ACanvas.Handle, Rect.Left, Rect.Top, Rect.Right,
+ Rect.Bottom);
+ if Image is TBitmap then
+ DrawBitmapTransparent(ACanvas, X, Y, TBitmap(Image),
+ TBitmap(Image).TransparentColor)
+ else
+ {if Image is TIcon then
+ begin
+ Ico := CreateRealSizeIcon(TIcon(Image));
+ try
+ GetIconSize(Ico, W, H);
+ DrawIconEx(ACanvas.Handle, (Rect.Right + Rect.Left - W) div 2,
+ (Rect.Top + Rect.Bottom - H) div 2, Ico, W, H, 0, 0, DI_NORMAL);
+ finally
+ DestroyIcon(Ico);
+ end;
+ end
+ else}
+ ACanvas.Draw(X, Y, Image);
+ finally
+ RestoreDC(ACanvas.Handle, SaveIndex);
+ end;
+ end;
+end;
+
+procedure TJvLookupControl.DrawImage(ACanvas: TCanvas; Rect: TRect;
+ ImageIndex: Integer);
+var
+ X, Y: Integer;
+begin
+ if Assigned(ImageList) and (ImageIndex > -1) then
+ begin
+ ACanvas.FillRect(Rect);
+ X := (Rect.Right + Rect.Left - ImageList.Width) div 2;
+ Y := (Rect.Top + Rect.Bottom - ImageList.Height) div 2;
+ ImageList.Draw(ACanvas, X, Y, ImageIndex);
+ end;
+end;
+
+function TJvLookupControl.GetPicture(Current, Empty: Boolean;
+ var TextMargin: Integer): TGraphic;
+begin
+ TextMargin := 0;
+ Result := nil;
+ if Assigned(FOnGetImage) then
+ FOnGetImage(Self, Empty, Result, TextMargin);
+end;
+
+function TJvLookupControl.GetImageIndex(Current, Empty: Boolean;
+ var TextMargin: Integer): Integer;
+begin
+ Result := -1;
+ TextMargin := 0;
+ if Assigned(FOnGetImageIndex) then
+ FOnGetImageIndex(Self, Empty, Result, TextMargin);
+end;
+
+function TJvLookupControl.Locate(const SearchField: TField;
+ const AValue: string; Exact: Boolean): Boolean;
+begin
+ FLocate.IndexSwitch := FIndexSwitch;
+ Result := False;
+ try
+ if not ValueIsEmpty(AValue) and (SearchField <> nil) then
+ begin
+ Result := FLocate.Locate(SearchField.FieldName, AValue, Exact, not IgnoreCase, True, RightTrimmedLookup);
+ if Result then
+ begin
+ if SearchField = FDisplayField then
+ FValue := FKeyField.AsString;
+ UpdateDisplayValue;
+ end;
+ end;
+ except
+ end;
+end;
+
+function TJvLookupControl.EmptyRowVisible: Boolean;
+begin
+ Result := DisplayEmpty <> '';
+end;
+
+procedure TJvLookupControl.UpdateDisplayValue;
+begin
+ if not ValueIsEmpty(FValue) then
+ begin
+ if FDisplayField <> nil then
+ FDisplayValue := FDisplayField.AsString
+ else
+ FDisplayValue := '';
+ end
+ else
+ FDisplayValue := '';
+end;
+
+function TJvLookupControl.GetWindowWidth: Integer;
+var
+ I: Integer;
+begin
+ Result := 0;
+ for I := 0 to FListFields.Count - 1 do
+ Inc(Result, TField(FListFields[I]).DisplayWidth);
+ Canvas.Font := Font;
+ Result := Min(Result * Canvas.TextWidth('M') + FListFields.Count * 4 +
+ GetSystemMetrics(SM_CXVSCROLL), Screen.Width);
+end;
+
+function TJvLookupControl.GetDefaultColor(
+ const DefaultColorType: TDefaultColorType): TColor;
+begin
+ if DefaultColorType = dctBrush then
+ Result := clWindow
+ else
+ Result := inherited GetDefaultColor(DefaultColorType);
+end;
+
+procedure TJvLookupControl.SetLookupFormat(const Value: string);
+begin
+ if Value <> FLookupFormat then
+ begin
+ CheckLookupFormat(Value);
+ FLookupFormat := Value;
+ ListLinkActiveChanged;
+ if FListActive then
+ DataLinkRecordChanged(nil);
+ end;
+end;
+
+function TJvLookupControl.DoFormatLine: string;
+var
+ J, LastFieldIndex: Integer;
+ AField: TField;
+ LStringList: array of string;
+ LVarList: array of TVarRec;
+begin
+ Result := '';
+ LastFieldIndex := FListFields.Count - 1;
+ if LookupFormat > '' then
+ begin
+ SetLength(LStringList, LastFieldIndex + 1);
+ SetLength(LVarList, LastFieldIndex + 1);
+
+ for J := 0 to LastFieldIndex do
+ begin
+ LStringList[J] := TField(FListFields[J]).DisplayText;
+ {$IFDEF SUPPORTS_UNICODE}
+ LVarList[J].VPWideChar := PWideChar(LStringList[J]);
+ LVarList[J].VType := vtPWideChar;
+ {$ELSE}
+ LVarList[J].VPChar := PAnsiChar(LStringList[J]);
+ LVarList[J].VType := vtPChar;
+ {$ENDIF SUPPORTS_UNICODE}
+ end;
+ Result := Format(LookupFormat, LVarList);
+ end
+ else
+ for J := 0 to LastFieldIndex do
+ begin
+ AField := TField(FListFields[J]);
+ Result := Result + AField.DisplayText;
+ if J < LastFieldIndex then
+ Result := Result + FFieldsDelimiter + ' ';
+ end;
+end;
+
+//=== { TJvDBLookupList } ====================================================
+
+constructor TJvDBLookupList.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ Width := 121;
+ BorderStyle := bsSingle;
+ ControlStyle := [csOpaque, csDoubleClicks];
+ RowCount := 7;
+ FDisableChangeBounds := False;
+end;
+
+procedure TJvDBLookupList.CreateParams(var Params: TCreateParams);
+begin
+ inherited CreateParams(Params);
+ with Params do
+ Style := Style or WS_VSCROLL;
+end;
+
+procedure TJvDBLookupList.CreateWnd;
+begin
+ inherited CreateWnd;
+ RowCount := RowCount;
+ UpdateScrollBar;
+end;
+
+procedure TJvDBLookupList.Loaded;
+begin
+ inherited Loaded;
+ Height := Height;
+end;
+
+function TJvDBLookupList.GetKeyIndex: Integer;
+var
+ FieldValue: string;
+begin
+ if not ValueIsEmpty(FValue) then
+ for Result := 0 to FRecordCount - 1 do
+ begin
+ FLookupLink.ActiveRecord := Result;
+ FieldValue := FKeyField.AsString;
+ FLookupLink.ActiveRecord := FRecordIndex;
+ if FieldValue = FValue then
+ Exit;
+ end;
+ Result := -1;
+end;
+
+procedure TJvDBLookupList.KeyDown(var Key: Word; Shift: TShiftState);
+var
+ Delta, KeyIndex, EmptyRow: Integer;
+begin
+ inherited;
+ FSelectEmpty := False;
+ EmptyRow := Ord(EmptyRowVisible);
+ if CanModify then
+ begin
+ Delta := 0;
+ case Key of
+ VK_UP, VK_LEFT:
+ Delta := -1;
+ VK_DOWN, VK_RIGHT:
+ Delta := 1;
+ VK_PRIOR:
+ Delta := 1 - (FRowCount - EmptyRow);
+ VK_NEXT:
+ Delta := (FRowCount - EmptyRow) - 1;
+ VK_HOME:
+ Delta := -MaxInt;
+ VK_END:
+ Delta := MaxInt;
+ end;
+ if Delta <> 0 then
+ begin
+ Key := 0;
+ if ValueIsEmpty(Value) and (EmptyRow > 0) and (Delta < 0) then
+ FSelectEmpty := True;
+ FSearchText := '';
+ if Delta = -MaxInt then
+ FLookupLink.DataSet.First
+ else
+ if Delta = MaxInt then
+ FLookupLink.DataSet.Last
+ else
+ begin
+ KeyIndex := GetKeyIndex;
+ if KeyIndex >= 0 then
+ begin
+ FLookupLink.DataSet.MoveBy(KeyIndex - FRecordIndex);
+ end
+ else
+ begin
+ KeyValueChanged;
+ Delta := 0;
+ end;
+ FLookupLink.DataSet.MoveBy(Delta);
+ if FLookupLink.DataSet.Bof and (Delta < 0) and (EmptyRow > 0) then
+ FSelectEmpty := True;
+ end;
+ SelectCurrent;
+ end;
+ end;
+end;
+
+procedure TJvDBLookupList.KeyPress(var Key: Char);
+begin
+ inherited KeyPress(Key);
+ ProcessSearchKey(Key);
+end;
+
+procedure TJvDBLookupList.KeyValueChanged;
+begin
+ if FListActive and not FLockPosition then
+ if not LocateKey then
+ FLookupLink.DataSet.First;
+end;
+
+procedure TJvDBLookupList.DisplayValueChanged;
+begin
+ if FListActive and not FLockPosition then
+ if not LocateDisplay then
+ FLookupLink.DataSet.First;
+end;
+
+procedure TJvDBLookupList.ListLinkActiveChanged;
+begin
+ try
+ inherited ListLinkActiveChanged;
+ finally
+ if FListActive and not FLockPosition then
+ begin
+ if Assigned(FMasterField) then
+ UpdateKeyValue
+ else
+ KeyValueChanged;
+ end
+ else
+ ListDataChanged;
+ end;
+end;
+
+procedure TJvDBLookupList.ListDataChanged;
+begin
+ if FListActive then
+ begin
+ FRecordIndex := FLookupLink.ActiveRecord;
+
+ // Note: if we cannot access the DataSet, then the record count will be
+ // the one from the link and can be different from the total record count.
+ // This may result in not displaying the scrollbar.
+ // This was changed from simply using FLookupLink.RecordCount to fix
+ // Mantis 3825.
+ if Assigned(FLookupLink.DataSet) and UseRecordCount then
+ FRecordCount := FLookupLink.DataSet.RecordCount
+ else
+ FRecordCount := FLookupLink.RecordCount;
+ FKeySelected := not ValueIsEmpty(FValue) or not FLookupLink.DataSet.Bof;
+ end
+ else
+ begin
+ FRecordIndex := 0;
+ FRecordCount := 0;
+ FKeySelected := False;
+ end;
+ if HandleAllocated then
+ begin
+ UpdateScrollBar;
+ Invalidate;
+ end;
+end;
+
+procedure TJvDBLookupList.ListLinkDataChanged;
+begin
+ ListDataChanged;
+end;
+
+procedure TJvDBLookupList.MouseDown(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer);
+begin
+ if Button = mbLeft then
+ begin
+ FSearchText := '';
+ if not FPopup then
+ begin
+ if CanFocus then
+ SetFocus;
+ if not FFocused then
+ Exit;
+ end;
+ if CanModify then
+ if ssDouble in Shift then
+ begin
+ if FRecordIndex = Y div GetTextHeight then
+ DblClick;
+ end
+ else
+ begin
+ MouseCapture := True;
+ FTracking := True;
+ SelectItemAt(X, Y);
+ end;
+ end;
+ inherited MouseDown(Button, Shift, X, Y);
+end;
+
+procedure TJvDBLookupList.MouseMove(Shift: TShiftState; X, Y: Integer);
+begin
+ if FTracking then
+ begin
+ SelectItemAt(X, Y);
+ FMousePos := Y;
+ TimerScroll;
+ end;
+ inherited MouseMove(Shift, X, Y);
+end;
+
+procedure TJvDBLookupList.MouseUp(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer);
+begin
+ if FTracking then
+ begin
+ StopTracking;
+ SelectItemAt(X, Y);
+ end;
+ inherited MouseUp(Button, Shift, X, Y);
+end;
+
+procedure TJvDBLookupList.DrawItemText(ACanvas: TCanvas; Rect: TRect;
+ Selected, IsEmpty: Boolean);
+var
+ J, W, X, ATop, TextWidth, LastFieldIndex: Integer;
+ S: string;
+ AField: TField;
+ R: TRect;
+ AAlignment: TAlignment;
+begin
+ TextWidth := ACanvas.TextWidth('M');
+ LastFieldIndex := FListFields.Count - 1;
+ R := Rect;
+ R.Right := R.Left;
+ S := '';
+ //if Selected then
+ Canvas.FillRect(Rect);
+ ATop := (R.Bottom + R.Top - CanvasMaxTextHeight(ACanvas)) div 2;
+ if FListStyle = lsFixed then
+ for J := 0 to LastFieldIndex do
+ begin
+ AField := TField(FListFields[J]);
+ if J < LastFieldIndex then
+ W := AField.DisplayWidth * TextWidth + 4
+ else
+ W := ClientWidth - R.Right;
+ if IsEmpty then
+ begin
+ if J = 0 then
+ begin
+ S := DisplayEmpty;
+ end
+ else
+ S := '';
+ end
+ else
+ S := AField.DisplayText;
+ X := 2;
+ AAlignment := AField.Alignment;
+ if UseRightToLeftAlignment then
+ ChangeBiDiModeAlignment(AAlignment);
+ case AAlignment of
+ taRightJustify:
+ X := W - ACanvas.TextWidth(S) - 3;
+ taCenter:
+ X := (W - ACanvas.TextWidth(S)) div 2;
+ end;
+ R.Left := R.Right;
+ R.Right := R.Right + W;
+ //if SysLocale.MiddleEast and UseRightToLeftReading then
+ // ACanvas.TextFlags := ACanvas.TextFlags or ETO_RTLREADING
+ //else
+ // ACanvas.TextFlags := ACanvas.TextFlags and not ETO_RTLREADING;
+ ACanvas.TextRect(R, R.Left + X, ATop, S);
+ if J < LastFieldIndex then
+ begin
+ ACanvas.MoveTo(R.Right, R.Top);
+ ACanvas.LineTo(R.Right, R.Bottom);
+ Inc(R.Right);
+ if R.Right >= ClientWidth then
+ Break;
+ end;
+ end
+ else
+ if not IsEmpty then
+ S := DoFormatLine;
+ if FListStyle = lsDelimited then
+ begin
+ if IsEmpty then
+ S := DisplayEmpty;
+ R.Left := Rect.Left;
+ R.Right := Rect.Right;
+ //if SysLocale.MiddleEast and UseRightToLeftReading then
+ // ACanvas.TextFlags := ACanvas.TextFlags or ETO_RTLREADING
+ //else
+ // ACanvas.TextFlags := ACanvas.TextFlags and not ETO_RTLREADING;
+ ACanvas.TextRect(R, R.Left + 2, ATop, S);
+ end;
+end;
+
+procedure TJvDBLookupList.Paint;
+var
+ I, J, TextHeight, TextMargin: Integer;
+ Image: TGraphic;
+ R, ImageRect: TRect;
+ Selected: Boolean;
+ ImgIndex: Integer;
+begin
+ Canvas.Font := Font;
+ TextHeight := GetTextHeight;
+ if ColorToRGB(Color) <> ColorToRGB(clBtnFace) then
+ Canvas.Pen.Color := clBtnFace
+ else
+ Canvas.Pen.Color := clBtnShadow;
+ for I := 0 to FRowCount - 1 do
+ begin
+ J := I - Ord(EmptyRowVisible);
+ Canvas.Font.Color := Font.Color;
+ Canvas.Brush.Color := Color;
+ Selected := not FKeySelected and (I = 0) and not EmptyRowVisible;
+ R.Top := I * TextHeight;
+ R.Bottom := R.Top + TextHeight;
+ if I < FRecordCount + Ord(EmptyRowVisible) then
+ begin
+ if (I = 0) and (J = -1) then
+ begin
+ if ValueIsEmpty(FValue) then
+ begin
+ Canvas.Font.Color := clHighlightText;
+ Canvas.Brush.Color := clHighlight;
+ Selected := True;
+ end
+ else
+ Canvas.Brush.Color := EmptyItemColor;
+ R.Left := 0;
+ R.Right := ClientWidth;
+ Image := GetPicture(False, True, TextMargin);
+ if TextMargin > 0 then
+ begin
+ ImageRect := Bounds(R.Left, R.Top, TextMargin, RectHeight(R));
+ if Image <> nil then
+ DrawPicture(Canvas, ImageRect, Image);
+ DrawItemText(Canvas, Bounds(R.Left + TextMargin, R.Top, RectWidth(R) - TextMargin,
+ RectHeight(R)), Selected, True);
+ end
+ else if Assigned(ImageList) then
+ begin
+ ImgIndex := GetImageIndex(False, True, TextMargin);
+ if TextMargin > 0 then
+ begin
+ ImageRect := Bounds(R.Left, R.Top, TextMargin, RectHeight(R));
+ if ImgIndex > -1 then
+ DrawImage(Canvas, ImageRect, ImgIndex);
+ DrawItemText(Canvas, Bounds(R.Left + TextMargin, R.Top, RectWidth(R) - TextMargin,
+ RectHeight(R)), Selected, True);
+ end
+ else
+ DrawItemText(Canvas, R, Selected, True);
+ end
+ else
+ DrawItemText(Canvas, R, Selected, True);
+ end
+ else
+ begin
+ FLookupLink.ActiveRecord := J;
+ if not ValueIsEmpty(FValue) and (FKeyField.AsString = FValue) then
+ begin
+ Canvas.Font.Color := clHighlightText;
+ Canvas.Brush.Color := clHighlight;
+ Selected := True;
+ end;
+ R.Left := 0;
+ R.Right := ClientWidth;
+ Image := GetPicture(False, False, TextMargin);
+ if TextMargin > 0 then
+ begin
+ ImageRect := Bounds(R.Left, R.Top, TextMargin, RectHeight(R));
+ if Image <> nil then
+ DrawPicture(Canvas, ImageRect, Image);
+ DrawItemText(Canvas, Bounds(R.Left + TextMargin, R.Top, RectWidth(R) - TextMargin,
+ RectHeight(R)), Selected, False);
+ end
+ else if Assigned(ImageList) then
+ begin
+ ImgIndex := GetImageIndex(False, False, TextMargin);
+ if TextMargin > 0 then
+ begin
+ ImageRect := Bounds(R.Left, R.Top, TextMargin, RectHeight(R));
+ if ImgIndex > -1 then
+ DrawImage(Canvas, ImageRect, ImgIndex);
+ DrawItemText(Canvas, Bounds(R.Left + TextMargin, R.Top, RectWidth(R) - TextMargin,
+ RectHeight(R)), Selected, False);
+ end
+ else
+ DrawItemText(Canvas, R, Selected, False);
+ end
+ else
+ DrawItemText(Canvas, R, Selected, False);
+ end;
+ end;
+ R.Left := 0;
+ R.Right := ClientWidth;
+ if J >= FRecordCount then
+ Canvas.FillRect(R);
+ if Selected and (FFocused or FPopup) then
+ Canvas.DrawFocusRect(R);
+ end;
+ if FRecordCount <> 0 then
+ FLookupLink.ActiveRecord := FRecordIndex;
+end;
+
+procedure TJvDBLookupList.SelectCurrent;
+begin
+ FLockPosition := True;
+ try
+ if FSelectEmpty then
+ ResetField
+ else
+ SelectKeyValue(FKeyField.AsString);
+ finally
+ FSelectEmpty := False;
+ FLockPosition := False;
+ end;
+end;
+
+procedure TJvDBLookupList.SelectItemAt(X, Y: Integer);
+var
+ Delta: Integer;
+begin
+ if Y < 0 then
+ Y := 0;
+ if Y >= ClientHeight then
+ Y := ClientHeight - 1;
+ Delta := Y div GetTextHeight;
+ if (Delta = 0) and EmptyRowVisible then
+ FSelectEmpty := True
+ else
+ begin
+ Delta := Delta - FRecordIndex;
+ if EmptyRowVisible then
+ Dec(Delta);
+ FLookupLink.DataSet.MoveBy(Delta);
+ end;
+ SelectCurrent;
+end;
+
+procedure TJvDBLookupList.UpdateDisplayEmpty(const AValue: string);
+begin
+ UpdateBufferCount(RowCount - Ord(AValue <> ''));
+end;
+
+procedure TJvDBLookupList.UpdateBufferCount(Rows: Integer);
+begin
+ if FLookupLink.BufferCount <> Rows then
+ begin
+ FLookupLink.BufferCount := Rows;
+ ListLinkDataChanged;
+ end;
+end;
+
+procedure TJvDBLookupList.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
+begin
+ FDisableChangeBounds := True;
+ UpdateBufferCount(FRowCount - Ord(EmptyRowVisible));
+ FDisableChangeBounds := False;
+ inherited SetBounds(ALeft, ATop, AWidth, AHeight);
+end;
+
+procedure TJvDBLookupList.SetRowCount(AValue: Integer);
+begin
+ if AValue < 1 then
+ AValue := 1;
+ if AValue > 50 then
+ AValue := 50;
+ Height := AValue * GetTextHeight + GetBorderSize;
+end;
+
+procedure TJvDBLookupList.StopTimer;
+begin
+ if FTimerActive then
+ begin
+ // (rom) why not a TTimer?
+ KillTimer(Handle, 1);
+ FTimerActive := False;
+ end;
+end;
+
+procedure TJvDBLookupList.StopTracking;
+begin
+ if FTracking then
+ begin
+ StopTimer;
+ FTracking := False;
+ MouseCapture := False;
+ end;
+end;
+
+procedure TJvDBLookupList.TimerScroll;
+var
+ Delta, Distance, Interval: Integer;
+begin
+ Delta := 0;
+ Distance := 0;
+ if FMousePos < 0 then
+ begin
+ Delta := -1;
+ Distance := -FMousePos;
+ end;
+ if FMousePos >= ClientHeight then
+ begin
+ Delta := 1;
+ Distance := FMousePos - ClientHeight + 1;
+ end;
+ if Delta = 0 then
+ StopTimer
+ else
+ begin
+ if FLookupLink.DataSet.MoveBy(Delta) <> 0 then
+ SelectCurrent;
+ Interval := 200 - Distance * 15;
+ if Interval < 0 then
+ Interval := 0;
+ SetTimer(Handle, 1, Interval, nil);
+ FTimerActive := True;
+ end;
+end;
+
+procedure TJvDBLookupList.UpdateScrollBar;
+var
+ Pos, Max: Integer;
+ ScrollInfo: TScrollInfo;
+ WantScrollbar: Boolean;
+begin
+ Pos := 0;
+ Max := 0;
+
+ if Assigned(FLookupLink.DataSet) and FLookupLink.Active then
+ begin
+ if UseRecordCount then
+ // FRecordCount is #records in the table
+ WantScrollbar := FRecordCount > (FRowCount - Ord(EmptyRowVisible))
+ else
+ // FRecordCount is #records in the link buffer; we don't know the #records
+ // in the table, but is it equal or bigger than FRecordCount, if FRecordCount
+ // is smaller than the # of rows in the dropdown then FRecordCount is equal
+ // to the #records in the table and no scrollbar is shown.
+ WantScrollbar := FRecordCount = (FRowCount - Ord(EmptyRowVisible));
+
+ if WantScrollbar then
+ begin
+ if UseRecordCount and (FLookupLink.DataSet.RecNo <> -1) then
+ begin
+ // We can be accurate
+ Max := FRecordCount{ - 1};
+ Pos := FLookupLink.DataSet.RecNo - 1;
+ end
+ else
+ begin
+ // Use an approximation
+ Max := 4;
+ if not FLookupLink.DataSet.Bof then
+ if not FLookupLink.DataSet.Eof then
+ Pos := 2
+ else
+ Pos := 4;
+ end;
+ end;
+ end;
+ ScrollInfo.cbSize := SizeOf(TScrollInfo);
+ ScrollInfo.fMask := SIF_POS or SIF_RANGE;
+ if not GetScrollInfo(Handle, SB_VERT, ScrollInfo) or
+ (ScrollInfo.nPos <> Pos) or (ScrollInfo.nMax <> Max) then
+ begin
+ ScrollInfo.nMin := 0;
+ ScrollInfo.nMax := Max;
+ ScrollInfo.nPos := Pos;
+ FDisableChangeBounds := True;
+ SetScrollInfo(Handle, SB_VERT, ScrollInfo, True);
+ FDisableChangeBounds := False;
+ end;
+end;
+
+procedure TJvDBLookupList.FontChanged(Sender: TObject);
+begin
+ inherited FontChanged(Sender);
+ if not (csReading in ComponentState) then
+ Height := Height;
+end;
+
+procedure TJvDBLookupList.WMCancelMode(var Msg: TLMessage);
+begin
+ StopTracking;
+ inherited;
+end;
+
+procedure TJvDBLookupList.WMTimer(var Msg: TLMessage);
+begin
+ TimerScroll;
+end;
+
+procedure TJvDBLookupList.WMNCHitTest(var Msg: TLMNCHitTest);
+begin
+ if csDesigning in ComponentState then
+ begin
+ if FLookupLink.Active then
+ DefaultHandler(Msg)
+ else
+ inherited;
+ end
+ else
+ inherited;
+end;
+
+function TJvDBLookupList.DoMouseWheelDown(Shift: TShiftState;
+ MousePos: TPoint): Boolean;
+var
+ ScrollableRowCount: Integer;
+begin
+ Result := inherited DoMouseWheelDown(Shift, MousePos);
+ if not Result then
+ begin
+ if FLookupLink.DataSet = nil then
+ Exit;
+
+ ScrollableRowCount := RowCount - Ord(EmptyRowVisible);
+
+ with FLookupLink.DataSet do
+ { ScrollableRowCount - FRecordIndex - 1 = #records till end of visible list
+ ScrollableRowCount div 2 = half visible list.
+ }
+ if Shift * [ssShift, ssCtrl] <> [] then
+ { 1 line down }
+ Result := MoveBy(ScrollableRowCount - FRecordIndex) <> 0
+ else
+ { Half Page down }
+ Result := MoveBy(ScrollableRowCount - FRecordIndex + ScrollableRowCount div 2 - 1) <> 0;
+ end;
+end;
+
+function TJvDBLookupList.DoMouseWheelUp(Shift: TShiftState;
+ MousePos: TPoint): Boolean;
+var
+ ScrollableRowCount: Integer;
+begin
+ Result := inherited DoMouseWheelUp(Shift, MousePos);
+ if not Result then
+ begin
+ if FLookupLink.DataSet = nil then
+ Exit;
+
+ ScrollableRowCount := RowCount - Ord(EmptyRowVisible);
+
+ with FLookupLink.DataSet do
+ { -FRecordIndex = #records till begin of visible list
+ ScrollableRowCount div 2 = half visible list.
+ }
+ if Shift * [ssShift, ssCtrl] <> [] then
+ { One line up }
+ Result := MoveBy(-FRecordIndex - 1) <> 0
+ else
+ { Half Page up }
+ Result := MoveBy(-FRecordIndex - ScrollableRowCount div 2) <> 0;
+ end;
+end;
+
+procedure TJvDBLookupList.ChangeBounds(ALeft, ATop, AWidth, AHeight: integer;
+ KeepBase: boolean);
+var
+ BorderSize, TextHeight, Rows: Integer;
+begin
+ if (not FDisableChangeBounds) then
+ begin
+ BorderSize := GetBorderSize;
+ TextHeight := GetTextHeight;
+ Rows := (AHeight - BorderSize) div TextHeight;
+ if Rows < 1 then
+ Rows := 1;
+ FRowCount := Rows;
+ if not (csReading in ComponentState) then
+ AHeight := Rows * TextHeight + BorderSize;
+ end;
+ inherited ChangeBounds(ALeft, ATop, AWidth, AHeight, KeepBase);
+end;
+
+procedure TJvDBLookupList.CalculatePreferredSize(var PreferredWidth,
+ PreferredHeight: integer; WithThemeSpace: Boolean);
+begin
+ inherited CalculatePreferredSize(PreferredWidth, PreferredHeight,
+ WithThemeSpace);
+ PreferredHeight := RowCount * GetItemHeight + GetBorderSize;
+end;
+
+procedure TJvDBLookupList.WMVScroll(var Msg: TLMVScroll);
+var
+ ScrollableRowCount: Integer;
+ ScrollInfo: TScrollInfo;
+begin
+ FSearchText := '';
+ if FLookupLink.DataSet = nil then
+ Exit;
+
+ ScrollableRowCount := RowCount - Ord(EmptyRowVisible);
+
+ with Msg, FLookupLink.DataSet do
+ case ScrollCode of
+ SB_LINEUP:
+ MoveBy(-FRecordIndex - 1);
+ SB_LINEDOWN:
+ MoveBy(ScrollableRowCount - FRecordIndex);
+ SB_PAGEUP:
+ MoveBy(-FRecordIndex - ScrollableRowCount + 1);
+ SB_PAGEDOWN:
+ MoveBy(ScrollableRowCount - FRecordIndex + ScrollableRowCount - 2);
+ SB_THUMBPOSITION, SB_THUMBTRACK:
+ begin
+ if UseRecordCount then
+ begin
+ if Pos = 0 then
+ First
+ else if Pos = FRecordCount - 1 then
+ Last
+ else
+ begin
+ ScrollInfo.cbSize := SizeOf(ScrollInfo);
+ ScrollInfo.fMask := SIF_POS;
+ if GetScrollInfo(Handle, SB_VERT, ScrollInfo) then
+ MoveBy(-ScrollInfo.nPos + Pos);
+ end;
+ end
+ else if ScrollCode = SB_THUMBPOSITION then
+ begin
+ case Pos of
+ 0:
+ First;
+ 1:
+ MoveBy(-FRecordIndex - ScrollableRowCount + 1);
+ 2:
+ Exit;
+ 3:
+ MoveBy(ScrollableRowCount - FRecordIndex + ScrollableRowCount - 2);
+ 4:
+ Last;
+ end;
+ end;
+ end;
+ SB_BOTTOM:
+ Last;
+ SB_TOP:
+ First;
+ end;
+end;
+
+//=== { TJvPopupDataList } ===================================================
+
+constructor TJvPopupDataList.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ if AOwner is TJvPopupDataListForm then
+ FCombo := TJvPopupDataListForm(AOwner).FCombo;
+ FPopup := True;
+ TabStop := False;
+end;
+
+procedure TJvPopupDataList.CMHintShow(var Msg: TLMessage);
+begin
+ // never show
+ Msg.Result := 1;
+end;
+
+procedure TJvPopupDataList.Click;
+begin
+ inherited Click;
+ if Assigned(FCombo) and TJvDBLookupCombo(FCombo).FListVisible then
+ TJvDBLookupCombo(FCombo).InvalidateText;
+end;
+
+procedure TJvPopupDataList.KeyPress(var Key: Char);
+begin
+ inherited KeyPress(Key);
+ if Assigned(FCombo) and TJvDBLookupCombo(FCombo).FListVisible then
+ TJvDBLookupCombo(FCombo).InvalidateText;
+end;
+
+{ TJvPopupDataListForm }
+
+procedure TJvPopupDataListForm.KeyPress(var Key: char);
+begin
+ inherited KeyPress(Key);
+ if Assigned(FCombo) then
+ begin
+ TJvDBLookupCombo(FCombo).KeyPress(Key);
+ if TJvDBLookupCombo(FCombo).FListVisible then
+ TJvDBLookupCombo(FCombo).InvalidateText;
+ end;
+end;
+
+procedure TJvPopupDataListForm.KeyDown(var Key: Word; Shift: TShiftState);
+begin
+ inherited KeyDown(Key, Shift);
+ if Assigned(FCombo) then
+ TJvPopupDataList(FCombo).KeyDown(Key, Shift);
+end;
+
+procedure TJvPopupDataListForm.DoShow;
+begin
+ inherited DoShow;
+ Application.AddOnDeactivateHandler(@AppDeactivate);
+end;
+
+procedure TJvPopupDataListForm.DoClose(var CloseAction: TCloseAction);
+begin
+ inherited DoClose(CloseAction);
+ Application.RemoveOnDeactivateHandler(@AppDeactivate);
+end;
+
+procedure TJvPopupDataListForm.AppDeactivate(Sender: TObject);
+begin
+ if Assigned(FCombo) and (FCombo is TJvDBLookupCombo) then
+ TJvDBLookupCombo(FCombo).CloseUp(False);
+end;
+
+procedure TJvPopupDataListForm.Deactivate;
+begin
+ if Assigned(FCombo) then
+ if FCombo is TJvDBLookupCombo then
+ begin
+ TJvDBLookupCombo(FCombo).FWhenClosed := GetTickCount64;
+ TJvDBLookupCombo(FCombo).CloseUp(False);
+ end;
+ inherited Deactivate;
+end;
+
+constructor TJvPopupDataListForm.CreateNew(AOwner: TComponent; Num: Integer);
+begin
+ inherited CreateNew(AOwner, Num);
+ ControlStyle := ControlStyle + [csNoDesignVisible];
+ ShowInTaskBar := stNever;
+ BorderStyle := bsNone;
+ FormStyle := fsStayOnTop;
+ PopupMode := pmAuto;
+ KeyPreview := True;
+ AutoSize := True;
+ FList := TJvPopupDataList.Create(Self);
+ FList.Parent := Self;
+ FList.Left := 0;
+ FList.Top := 0;
+ //FList.Align := alClient;
+end;
+
+//=== { TJvDBLookupCombo } ===================================================
+
+constructor TJvDBLookupCombo.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ ControlStyle := ControlStyle + [csReplicatable] - [csSetCaption];
+ FDataListForm := TJvPopupDataListForm.CreateNew(Self);
+ FDataListForm.Visible := False;
+ FDataListForm.FCombo := Self;
+ FDataListForm.FList.FCombo := Self;
+ FDataListForm.FList.OnMouseUp := @ListMouseUp;
+ FButtonWidth := GetSystemMetrics(SM_CXVSCROLL);
+ FDropDownCount := 8;
+ FDisplayValues := TStringList.Create;
+ FSelImage := TPicture.Create;
+ FSelImageIndex := -1;
+ Height := GetMinHeight;
+ FEscapeKeyReset := True;
+ FDeleteKeyClear := True;
+ FLastValue := Unassigned;
+ BorderStyle := bsSingle;
+ Width := 145;
+ Height := 0;
+end;
+
+destructor TJvDBLookupCombo.Destroy;
+begin
+ FSelImage.Free;
+ FSelImage := nil;
+ FreeAndNil(FDisplayValues);
+ inherited Destroy;
+end;
+
+procedure TJvDBLookupCombo.ReadEscapeClear(Reader: TReader);
+begin
+ DeleteKeyClear := Reader.ReadBoolean;
+end;
+
+procedure TJvDBLookupCombo.DefineProperties(Filer: TFiler);
+begin
+ inherited DefineProperties(Filer);
+ // backward compatiblity
+ Filer.DefineProperty('EscapeClear', @ReadEscapeClear, nil, False);
+end;
+
+procedure TJvDBLookupCombo.DataLinkUpdateData;
+begin
+ inherited DataLinkUpdateData;
+ if (Field <> nil) and FDataLink.Active then
+ FLastValue := Field.Value;
+end;
+
+procedure TJvDBLookupCombo.DataLinkRecordChanged(AField: TField);
+begin
+ if (AField = nil) and (Field <> nil) and (FDataLink.Active) then
+ FLastValue := Field.Value;
+ inherited DataLinkRecordChanged(AField);
+end;
+
+function ParentFormVisible(AControl: TControl): Boolean;
+var
+ Form: TCustomForm;
+begin
+ Form := GetParentForm(AControl);
+ Result := Assigned(Form) and Form.Visible;
+end;
+
+procedure TJvDBLookupCombo.CloseUp(Accept: Boolean);
+var
+ ListValue: string;
+begin
+ if FListVisible then
+ begin
+ if GetCapture <> 0 then
+ SendMessage(GetCapture, LM_CANCELMODE, 0, 0);
+ { (rb) Need to check ParentFormVisible always before SetFocus? Delphi doesn't.
+ Not checking whether the parent form is visible typically gives errors
+ when closing forms with non-focusable buttons (eg speed/toolbuttons) }
+ if ParentFormVisible(Self) and CanFocus then
+ SetFocus;
+ ListValue := FDataListForm.FList.Value;
+ FDataListForm.Visible := False;
+ FListVisible := False;
+ FDataListForm.FList.LookupSource := nil;
+ InvalidateDropDownButton;
+ Invalidate;
+ FSearchText := '';
+ FDataListForm.FList.FSearchText := '';
+ if Accept and CanModify and (Value <> ListValue) then
+ SelectKeyValue(ListValue);
+ if Assigned(FOnCloseUp) then
+ FOnCloseUp(Self);
+ end;
+end;
+
+procedure TJvDBLookupCombo.CMHintShow(var Msg: TLMessage);
+begin
+ // don't show if list is visible
+ Msg.Result := LRESULT(Ord(FListVisible));
+end;
+
+procedure TJvDBLookupCombo.DoEnter;
+begin
+ if (Field <> nil) and FDataLink.Active and VarIsEmpty(FLastValue) then
+ FLastValue := Field.Value;
+ inherited DoEnter;
+end;
+
+function TJvDBLookupCombo.DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean;
+begin
+ Result := inherited DoMouseWheelDown(Shift, MousePos);
+ if not Result then
+ begin
+ if FLookupLink.DataSet = nil then
+ Exit;
+
+ { Simulate up or down key, see code in KeyDown }
+ if FListActive then
+ if ssAlt in Shift then
+ begin
+ if FListVisible then
+ CloseUp(True)
+ else
+ DropDown;
+ Result := True;
+ end
+ else
+ if not FListVisible and not ReadOnly then
+ begin
+ if not LocateKey then
+ FLookupLink.DataSet.First
+ else
+ FLookupLink.DataSet.MoveBy(1);
+ SelectKeyValue(FKeyField.AsString);
+ Result := True;
+ end;
+ if not Result and FListVisible then
+ Result := FDataListForm.FList.DoMouseWheelDown(Shift, MousePos);
+ end;
+end;
+
+function TJvDBLookupCombo.DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean;
+begin
+ Result := inherited DoMouseWheelDown(Shift, MousePos);
+ if not Result then
+ begin
+ if FLookupLink.DataSet = nil then
+ Exit;
+
+ { Simulate up or down key, see code in KeyDown }
+ if FListActive then
+ if ssAlt in Shift then
+ begin
+ if FListVisible then
+ CloseUp(True)
+ else
+ DropDown;
+ Result := True;
+ end
+ else
+ if not FListVisible and not ReadOnly then
+ begin
+ if not LocateKey then
+ FLookupLink.DataSet.First
+ else
+ FLookupLink.DataSet.MoveBy(-1);
+ SelectKeyValue(FKeyField.AsString);
+ Result := True;
+ end;
+ if not Result and FListVisible then
+ Result := FDataListForm.FList.DoMouseWheelUp(Shift, MousePos);
+ end;
+end;
+
+procedure TJvDBLookupCombo.DropDown;
+var
+ P: TPoint;
+ I, Y: Integer;
+ S: string;
+ SelValue: string;
+ RecordCount: Integer;
+ Monitor: TMonitor;
+ Rect: TRect;
+begin
+ if not FListVisible and {FListActive} CanModify
+ and ((FWhenClosed = 0) or (FWhenClosed + 100 < GetTickCount64)) then
+ begin
+ if Assigned(FOnDropDown) then
+ FOnDropDown(Self);
+ SelValue := Value; // backup before anything invokes a OnDataChange event
+
+ FDataListForm.FList.Color := Color;
+ FDataListForm.FList.Font := Font;
+ FDataListForm.FList.EmptyItemColor := EmptyItemColor;
+
+ FDataListForm.FList.ItemHeight := ItemHeight;
+ FDataListForm.FList.ReadOnly := not CanModify;
+ FDataListForm.FList.EmptyValue := EmptyValue;
+ FDataListForm.FList.DisplayEmpty := DisplayEmpty;
+ FDataListForm.FList.UseRecordCount := UseRecordCount;
+ if Assigned(FLookupLink.DataSet) and UseRecordCount then
+ begin
+ RecordCount := FLookupLink.DataSet.RecordCount;
+ if EmptyRowVisible then // Mantis 3884
+ Inc(RecordCount);
+ end
+ else
+ RecordCount := MaxInt;
+
+ FDataListForm.FList.LookupField := FLookupFieldName;
+ FDataListForm.FList.LookupFormat := FLookupFormat;
+ FDataListForm.FList.ListStyle := FListStyle;
+ FDataListForm.FList.FieldsDelimiter := FFieldsDelimiter;
+ FDataListForm.FList.IgnoreCase := FIgnoreCase;
+ FDataListForm.FList.IndexSwitch := FIndexSwitch;
+ FDataListForm.FList.OnGetImage := OnGetImage;
+ FDataListForm.FList.ImageList := ImageList;
+ FDataListForm.FList.OnGetImageIndex := OnGetImageIndex;
+ // polaris if FDisplayField <> nil then FAlignment := FDisplayField.Alignment;
+ S := '';
+ for I := 0 to FListFields.Count - 1 do
+ S := S + TField(FListFields[I]).FieldName + ';';
+ FDataListForm.FList.LookupDisplay := S;
+ FDataListForm.FList.LookupDisplayIndex := FListFields.IndexOf(FDisplayField);
+ {FDataListForm.FList.FLockPosition := True;}
+ try
+ FDataListForm.FList.LookupSource := FLookupLink.DataSource;
+ finally
+ {FDataListForm.FList.FLockPosition := False;}
+ end;
+ FDataListForm.FList.SetValueKey(SelValue);
+ {FDataListForm.FList.KeyValueChanged;}
+ if FDropDownWidth > 0 then
+ FDataListForm.FList.Width := FDropDownWidth
+ else
+ if FDropDownWidth < 0 then
+ FDataListForm.FList.Width := Max(Width, FDataListForm.FList.GetWindowWidth)
+ else
+ FDataListForm.FList.Width := Width;
+
+ if (DropDownCount > RecordCount) then
+ FDataListForm.FList.RowCount := RecordCount
+ else
+ FDataListForm.FList.RowCount := DropDownCount;
+
+ // Adjust if too close to workarea borders
+
+ //Monitor := FindMonitor(MonitorFromWindow(Handle, MONITOR_DEFAULTTONEAREST));
+ //Rect := GetWorkAreaRect(Monitor);
+ Monitor := Screen.MonitorFromWindow(Handle);
+ Rect := Monitor.WorkareaRect;
+
+ P := Parent.ClientToScreen(Point(Left, Top));
+ Y := P.Y + Height;
+ if Y + FDataListForm.FList.Height > Rect.Bottom then
+ Y := P.Y - FDataListForm.FList.Height;
+ case FDropDownAlign of
+ daRight:
+ Dec(P.X, FDataListForm.FList.Width - Width);
+ daCenter:
+ Dec(P.X, (FDataListForm.FList.Width - Width) div 2);
+ end;
+ if P.X + FDataListForm.FList.Width > Rect.Right then
+ P.X := Rect.Right - FDataListForm.FList.Width;
+
+ (*
+ { Use slide-open effect for combo boxes if wanted.}
+ SystemParametersInfo(SPI_GETCOMBOBOXANIMATION, 0, @Animate, 0);
+ if Assigned(AnimateWindowProc) and Animate then
+ begin
+ { Can't use SWP_SHOWWINDOW here, because the window is then immediately shown }
+ SetWindowPos(FDataListForm.FList.Handle, HWND_TOP, Max(P.X, Rect.Left), Y, 0, 0,
+ SWP_NOSIZE or SWP_NOACTIVATE {or SWP_SHOWWINDOW});
+ if Y < P.Y then
+ SlideStyle := AW_VER_NEGATIVE
+ else
+ SlideStyle := AW_VER_POSITIVE;
+ { 150 is a bit arbitrary (<200 is recommended) }
+ AnimateWindowProc(FDataListForm.FList.Handle, 150, SlideStyle or AW_SLIDE);
+ ShowWindow(FDataListForm.FList.Handle, SW_SHOWNOACTIVATE);
+ { Pre XP systems seem to need this }
+ FDataListForm.FList.Invalidate;
+ end
+ else
+ *)
+ {SetWindowPos(FDataListForm.Handle, HWND_TOP, Max(P.X, Rect.Left), Y, 0, 0,
+ SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);}
+
+ FDataListForm.Left := Max(P.X, Rect.Left);
+ FDataListForm.Top := Y;
+ if (DropDownCount > RecordCount) then
+ FDataListForm.FList.RowCount := RecordCount
+ else
+ FDataListForm.FList.RowCount := DropDownCount;
+ FDataListForm.Width := FDataListForm.FList.Width;
+ FDataListForm.Height := FDataListForm.FList.Height;
+
+ FDataListForm.Visible := True;
+ //FDataListForm.FList.SetFocus;
+
+ FListVisible := True;
+ InvalidateText;
+ InvalidateDropDownButton;
+ Repaint;
+ end;
+end;
+
+function TJvDBLookupCombo.GetMinHeight: Integer;
+begin
+ Result := DefaultTextHeight + GetBorderSize + 3;
+end;
+
+procedure TJvDBLookupCombo.UpdateFieldText;
+var
+ I: Integer;
+ S: string;
+begin
+ if FDisplayValues <> nil then
+ FDisplayValues.Clear;
+ if DisplayAllFields then
+ begin
+ S := DoFormatLine;
+ if (ListStyle = lsFixed) and Assigned(FDisplayValues) then
+ for I := 0 to FListFields.Count - 1 do
+ //begin
+ //if S <> '' then
+ // S := S + FFieldsDelimiter + ' ';
+ //S := S + TField(FListFields[I]).DisplayText;
+ // begin
+ with TField(FListFields[I]) do
+ FDisplayValues.AddObject(DisplayText,
+ TObject(PtrInt(MakeLong(DisplayWidth, Ord(Alignment)))));
+ // end;
+ //end;
+ if S = '' then
+ S := FDisplayField.DisplayText;
+ inherited Text := S;
+ end
+ else
+ inherited Text := FDisplayField.DisplayText;
+ FAlignment := FDisplayField.Alignment;
+end;
+
+function TJvDBLookupCombo.GetDisplayValues(Index: Integer): string;
+begin
+ if Assigned(FDisplayValues) and (FDisplayValues.Count > Index) then
+ Result := FDisplayValues[Index]
+ else
+ Result := FDisplayValue;
+end;
+
+function TJvDBLookupCombo.GetText: string;
+begin
+ Result := inherited Text;
+end;
+
+procedure TJvDBLookupCombo.InvalidateText;
+var
+ R: TRect;
+begin
+ if BiDiMode = bdRightToLeft then
+ SetRect(R, FButtonWidth + 1, 1, ClientWidth - 1, ClientHeight - 1)
+ else
+ SetRect(R, 1, 1, ClientWidth - FButtonWidth - 1, ClientHeight - 1);
+ InvalidateRect(Self.Handle, @R, False);
+ UpdateWindow(Self.Handle);
+end;
+
+procedure TJvDBLookupCombo.KeyDown(var Key: Word; Shift: TShiftState);
+var
+ Delta: Integer;
+begin
+ inherited KeyDown(Key, Shift); // Let the user override the behavior
+ if FListActive and ((Key = VK_UP) or (Key = VK_DOWN)) then
+ begin
+ if ssAlt in Shift then
+ begin
+ if FListVisible then
+ CloseUp(True)
+ else
+ DropDown;
+ Key := 0;
+ end
+ else
+ if not FListVisible and not ReadOnly then
+ begin
+ if not LocateKey then
+ FLookupLink.DataSet.First
+ else
+ begin
+ if Key = VK_UP then
+ Delta := -1
+ else
+ Delta := 1;
+ FLookupLink.DataSet.MoveBy(Delta);
+ end;
+ SelectKeyValue(FKeyField.AsString);
+ Key := 0;
+ end;
+ end
+ else if not FListVisible and (Key = VK_DELETE) and ([ssShift, ssAlt, ssCtrl] * Shift = []) then
+ begin
+ if DeleteKeyClear and not ValueIsEmpty(FValue) and CanModify then
+ begin
+ ResetField;
+ if FValue = FEmptyValue then
+ Key := 0;
+ end;
+ end;
+
+ if (Key <> 0) and FListVisible then
+ FDataListForm.FList.KeyDown(Key, Shift);
+end;
+
+procedure TJvDBLookupCombo.KeyPress(var Key: Char);
+begin
+ inherited KeyPress(Key);
+ if FListVisible then
+ begin
+ if TabSelects and IsDropDown and (Key = Tab) then
+ Key := Cr;
+
+ if (Key = Cr) or (Key = Esc) then
+ begin
+ CloseUp(Key = Cr);
+ Key := #0;
+ end
+ else
+ FDataListForm.FList.KeyPress(Key)
+ end
+ else
+ begin
+ if Key >= #32 then
+ begin
+ DropDown;
+ if FListVisible then
+ FDataListForm.FList.KeyPress(Key);
+ end
+ else
+ if (Key = Esc) and FEscapeKeyReset then
+ begin
+ if (Field <> nil) and FDataLink.Active and CanModify and
+ not VarIsEmpty(FLastValue) and (Field.Value <> FLastValue) and FDataLink.Edit then
+ begin
+ Field.Value := FLastValue;
+ Key := #0;
+ end;
+ end;
+ end;
+ //if CharInSet(Key, [Cr, Esc]) then
+ // GetParentForm(Self).Perform(CM_DIALOGKEY, Byte(Key), 0);
+end;
+
+procedure TJvDBLookupCombo.DisplayValueChanged;
+begin
+ if FListActive and LocateDisplay then
+ begin
+ FValue := FKeyField.AsString;
+ UpdateFieldText;
+ end
+ else
+ begin
+ FValue := FEmptyValue;
+ inherited Text := DisplayEmpty;
+ if FDisplayValues <> nil then
+ FDisplayValues.Clear;
+ FAlignment := taLeftJustify;
+ end;
+ UpdateDisplayValue;
+ UpdateCurrentImage;
+ Invalidate;
+end;
+
+procedure TJvDBLookupCombo.KeyValueChanged;
+begin
+ if FLookupMode then
+ begin
+ if FDisplayValues <> nil then
+ FDisplayValues.Clear;
+ if FDataLink.Active and (FDataField <> nil) then {begin
+ inherited Text := FDataField.DisplayText;
+ FAlignment := FDataField.Alignment;
+ end}
+ if ValueIsEmpty(FValue) then
+ begin
+ inherited Text := DisplayEmpty;
+ FAlignment := taLeftJustify;
+ end
+ else
+ begin
+ inherited Text := FDataField.DisplayText;
+ FAlignment := FDataField.Alignment;
+ end
+ else
+ inherited Text := '';
+ end
+ else
+ if FListActive and LocateKey then
+ UpdateFieldText
+ else
+ if FListActive then
+ begin
+ FValue := FEmptyValue;
+ inherited Text := DisplayEmpty;
+ if FDisplayValues <> nil then
+ FDisplayValues.Clear;
+ FAlignment := taLeftJustify;
+ end
+ else
+ begin
+ if csDesigning in ComponentState then
+ inherited Text := DisplayEmpty
+ else
+ inherited Text := '';
+ if FDisplayValues <> nil then
+ FDisplayValues.Clear;
+ end;
+ UpdateDisplayValue;
+ UpdateCurrentImage;
+ Invalidate;
+end;
+
+procedure TJvDBLookupCombo.SetFieldsDelimiter(AValue: Char);
+begin
+ if FFieldsDelimiter <> AValue then
+ begin
+ inherited SetFieldsDelimiter(AValue);
+ if (ListStyle = lsDelimited) and DisplayAllFields and
+ not (csReading in ComponentState) then
+ KeyValueChanged;
+ end;
+end;
+
+procedure TJvDBLookupCombo.SetListStyle(AValue: TLookupListStyle);
+begin
+ if FListStyle <> AValue then
+ begin
+ FListStyle := AValue;
+ if DisplayAllFields and not (csReading in ComponentState) then
+ KeyValueChanged;
+ end;
+end;
+
+function TJvDBLookupCombo.GetDisplayAllFields: Boolean;
+begin
+ if FLookupMode then
+ Result := False
+ else
+ Result := FDisplayAllFields;
+end;
+
+procedure TJvDBLookupCombo.SetDisplayAllFields(AValue: Boolean);
+begin
+ if FDisplayAllFields <> AValue then
+ begin
+ if FLookupMode then
+ FDisplayAllFields := False
+ else
+ FDisplayAllFields := AValue;
+ if not (csReading in ComponentState) and not FLookupMode then
+ KeyValueChanged
+ else
+ Invalidate;
+ end;
+end;
+
+procedure TJvDBLookupCombo.ListLinkDataChanged;
+begin
+ if FDataLink.Active and FDataLink.DataSet.IsLinkedTo(LookupSource) then
+ if FListActive then
+ DataLinkRecordChanged(nil);
+end;
+
+procedure TJvDBLookupCombo.ListLinkDataSetChanged;
+begin
+ inherited ListLinkDataSetChanged;
+ if not FInListDataSetChanged and not FListVisible and
+ (FLookupSource <> nil) and (FLookupSource.DataSet <> nil) and (FLookupSource.DataSet.State = dsBrowse) then
+ begin
+ FInListDataSetChanged := True;
+ try
+ if FListActive and Assigned(FMasterField) then
+ UpdateKeyValue
+ else
+ KeyValueChanged;
+ finally
+ FInListDataSetChanged := False;
+ end;
+ end;
+end;
+
+procedure TJvDBLookupCombo.ListLinkActiveChanged;
+begin
+ inherited ListLinkActiveChanged;
+ if FListActive and Assigned(FMasterField) then
+ UpdateKeyValue
+ else
+ KeyValueChanged;
+end;
+
+procedure TJvDBLookupCombo.ListMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+begin
+ if Button = mbLeft then
+ CloseUp(PtInRect(FDataListForm.FList.ClientRect, Point(X, Y)));
+end;
+
+procedure TJvDBLookupCombo.MouseDown(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer);
+begin
+ if Button = mbLeft then
+ begin
+ if CanFocus then
+ SetFocus;
+ if not FFocused then
+ Exit;
+ if FListVisible then
+ CloseUp(False)
+ else
+ if {FListActive} CanModify then
+ begin
+ MouseCapture := True;
+ FTracking := True;
+ TrackButton(X, Y);
+ DropDown;
+ end;
+ end;
+ inherited MouseDown(Button, Shift, X, Y);
+end;
+
+procedure TJvDBLookupCombo.MouseMove(Shift: TShiftState; X, Y: Integer);
+var
+ ListPos: TPoint;
+ MousePos: {$IFDEF CPU64}TPoint{$ELSE}TSmallPoint{$ENDIF};
+begin
+ SetMouseOverButton(PtInRect(GetDropDownButtonRect, Point(X, Y)));
+ if FTracking then
+ begin
+ TrackButton(X, Y);
+ if FListVisible then
+ begin
+ ListPos := FDataListForm.FList.ScreenToClient(ClientToScreen(Point(X, Y)));
+ if PtInRect(FDataListForm.FList.ClientRect, ListPos) then
+ begin
+ StopTracking;
+ {$IFDEF CPU64}
+ MousePos := ListPos;
+ {$ELSE}
+ MousePos := PointToSmallPoint(ListPos);
+ {$ENDIF}
+ SendMessage(FDataListForm.FList.Handle, LM_LBUTTONDOWN, 0, LPARAM(MousePos));
+ Exit;
+ end;
+ end;
+ end;
+ inherited MouseMove(Shift, X, Y);
+end;
+
+procedure TJvDBLookupCombo.MouseUp(Button: TMouseButton; Shift: TShiftState;
+ X, Y: Integer);
+begin
+ StopTracking;
+ inherited MouseUp(Button, Shift, X, Y);
+end;
+
+procedure TJvDBLookupCombo.SetMouseOverButton(AValue: Boolean);
+begin
+ if AValue <> FMouseOverButton then
+ begin
+ FMouseOverButton := AValue;
+ InvalidateDropDownButton;
+ end;
+end;
+
+procedure TJvDBLookupCombo.CreateWnd;
+begin
+ inherited CreateWnd;
+ Height := Max(Height, GetMinHeight);
+end;
+
+procedure TJvDBLookupCombo.SetReadOnly(AValue: Boolean);
+begin
+ inherited SetReadOnly(AValue);
+ InvalidateFrame;
+end;
+
+function TJvDBLookupCombo.GetDropDownButtonRect: TRect;
+begin
+ Result := Rect(ClientWidth - (FButtonWidth - (Width - ClientWidth) div 2), 0, Width, ClientHeight);
+end;
+
+procedure TJvDBLookupCombo.InvalidateFrame;
+begin
+ if StyleServices.Enabled and HandleAllocated then
+ RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_FRAME);
+end;
+
+procedure TJvDBLookupCombo.InvalidateDropDownButton;
+var
+ R: TRect;
+begin
+ if StyleServices.Enabled and HandleAllocated then
+ begin
+ R := GetDropDownButtonRect;
+ InvalidateRect(Handle, @R, True);
+ end;
+end;
+
+procedure TJvDBLookupCombo.UpdateCurrentImage;
+begin
+ FSelImage.Assign(nil);
+ FSelMargin := 0;
+ FSelMarginImg := 0;
+ FSelImage.Graphic := inherited GetPicture(False, ValueIsEmpty(Value), FSelMargin);
+ FSelImageIndex := inherited GetImageIndex(False, ValueIsEmpty(Value), FSelMarginImg);
+end;
+
+function TJvDBLookupCombo.GetPicture(Current, Empty: Boolean;
+ var TextMargin: Integer): TGraphic;
+begin
+ if Current then
+ begin
+ TextMargin := 0;
+ Result := nil;
+ if (FSelImage <> nil) and (FSelImage.Graphic <> nil) and not FSelImage.Graphic.Empty then
+ begin
+ Result := FSelImage.Graphic;
+ TextMargin := FSelMargin;
+ end;
+ end
+ else
+ Result := inherited GetPicture(Current, Empty, TextMargin);
+end;
+
+function TJvDBLookupCombo.GetImageIndex(Current, Empty: Boolean;
+ var TextMargin: Integer): Integer;
+begin
+ if Current then
+ begin
+ TextMargin := 0;
+ Result := -1;
+ if FSelImageIndex > -1 then
+ begin
+ Result := FSelImageIndex;
+ TextMargin := FSelMarginImg;
+ end;
+ end
+ else
+ Result := inherited GetImageIndex(Current, Empty, TextMargin);
+end;
+
+procedure TJvDBLookupCombo.PaintDisplayValues(ACanvas: TCanvas; R: TRect;
+ ALeft: Integer);
+var
+ I, LastIndex, TxtWidth: Integer;
+ X, W, ATop, ARight: Integer;
+ S: string;
+begin
+ if ColorToRGB(Self.Color) <> ColorToRGB(clBtnFace) then
+ ACanvas.Pen.Color := clBtnFace
+ else
+ ACanvas.Pen.Color := clBtnShadow;
+ LastIndex := FDisplayValues.Count - 1;
+ TxtWidth := ACanvas.TextWidth('M');
+ ATop := Max(0, (RectHeight(R) - CanvasMaxTextHeight(ACanvas)) div 2);
+ ARight := R.Right;
+ Inc(R.Left, ALeft);
+ for I := 0 to LastIndex do
+ begin
+ S := FDisplayValues[I];
+ W := LoWord(PtrInt(FDisplayValues.Objects[I]));
+ if I < LastIndex then
+ W := W * TxtWidth + 4
+ else
+ W := ARight - R.Left;
+ X := 2;
+ R.Right := R.Left + W;
+ case TAlignment(HiWord(PtrInt(FDisplayValues.Objects[I]))) of
+ taRightJustify:
+ X := W - ACanvas.TextWidth(S) - 3;
+ taCenter:
+ X := (W - ACanvas.TextWidth(S)) div 2;
+ end;
+ ACanvas.TextRect(R, R.Left + Max(0, X), ATop, S);
+ Inc(R.Left, W);
+ if I < LastIndex then
+ begin
+ ACanvas.MoveTo(R.Right, R.Top);
+ ACanvas.LineTo(R.Right, R.Bottom);
+ Inc(R.Left);
+ end;
+ if R.Left >= ARight then
+ Break;
+ end;
+end;
+
+procedure TJvDBLookupCombo.WMEraseBkgnd(var Message: TLMEraseBkgnd);
+var
+ IsClipped: Boolean;
+ SaveRgn: HRGN;
+ ButtonLeft: Integer;
+begin
+ IsClipped := False;
+ SaveRgn := 0;
+ if not DoubleBuffered and
+ (TLMessage(Message).WParam <> WPARAM(TLMessage(Message).LParam)) //and
+ { Do not exclude parts if we are painting into a memory device context or
+ into a child's device context through DrawParentBackground(). }
+ {(WindowFromDC(Message.DC) = Handle)} then
+ begin
+ SaveRgn := CreateRectRgn(0, 0, 1, 1);
+ IsClipped := GetClipRgn(Message.DC, SaveRgn) = 1;
+ { Exclude the edit rectangle and the drop down button. }
+ ButtonLeft := ClientWidth - FButtonWidth;
+ ExcludeClipRect(Message.DC, 1, 1, ButtonLeft - 1, ClientHeight - 1);
+ ExcludeClipRect(Message.DC, ButtonLeft, 0, ClientWidth, ClientHeight);
+ end;
+ inherited;
+
+ { Restore the backuped clipping region }
+ if SaveRgn <> 0 then
+ begin
+ if IsClipped then
+ SelectClipRgn(Message.DC, SaveRgn)
+ else
+ SelectClipRgn(Message.DC, 0);
+ DeleteObject(SaveRgn);
+ end;
+end;
+
+procedure TJvDBLookupCombo.Paint;
+var
+ W, X, Flags, TextMargin: Integer;
+ AText: string;
+ Selected, DrawList, IsEmpty: Boolean;
+ R, ImageRect: TRect;
+ Image: TGraphic;
+ ImgIndex: Integer;
+ Alignment: TAlignment;
+ State: TThemedComboBox;
+ Details: TThemedElementDetails;
+begin
+ if csDestroying in ComponentState then
+ Exit;
+ Selected := FFocused and not FListVisible and not (csPaintCopy in ControlState);
+
+ Canvas.Font := Font;
+ if Color = clDefault then
+ Canvas.Brush.Color := GetDefaultColor(dctBrush)
+ else
+ Canvas.Brush.Color := Color;
+ if Selected then
+ begin
+ Canvas.Font.Color := clHighlightText;
+ Canvas.Brush.Color := clHighlight;
+ end
+ else
+ if not Enabled then
+ Canvas.Font.Color := clGrayText;
+
+ AText := inherited Text;
+ Alignment := FAlignment;
+ Image := nil;
+ IsEmpty := False;
+ ImgIndex := -1;
+ DrawList := DisplayAllFields;
+ if (csPaintCopy in ControlState) and (FDataField <> nil) then
+ begin
+ DrawList := False;
+ AText := FDataField.DisplayText;
+ Alignment := FDataField.Alignment;
+ end;
+ TextMargin := 0;
+ if FListVisible then
+ begin
+ DrawList := False;
+ if FDataListForm.FList.FSearchText <> '' then
+ AText := FDataListForm.FList.FSearchText
+ else
+ begin
+ if FDataListForm.FList.ValueIsEmpty(FDataListForm.FList.Value) then
+ begin
+ AText := DisplayEmpty;
+ IsEmpty := True;
+ Image := GetPicture(False, True, TextMargin);
+ if (Image = nil) and Assigned(ImageList) then
+ ImgIndex := GetImageIndex(False, True, TextMargin);
+ end
+ else
+ if FDataListForm.FList.FKeyField.AsString = FDataListForm.FList.Value then
+ begin
+ AText := FDataListForm.FList.FDisplayField.DisplayText;
+ Image := FDataListForm.FList.GetPicture(False, False, TextMargin);
+ if (Image = nil) and Assigned(ImageList) then
+ ImgIndex := GetImageIndex(False, False, TextMargin);
+ end
+ else
+ begin
+ Image := GetPicture(True, False, TextMargin);
+ if (Image = nil) and Assigned(ImageList) then
+ ImgIndex := GetImageIndex(False, False, TextMargin);
+ end;
+ end;
+ end
+ else
+ begin
+ if csPaintCopy in ControlState then
+ Image := nil
+ else
+ begin
+ IsEmpty := ValueIsEmpty(Value);
+ Image := GetPicture(True, IsEmpty, TextMargin);
+ if (Image = nil) and Assigned(ImageList) then
+ ImgIndex := GetImageIndex(False, IsEmpty, TextMargin);
+ end;
+ end;
+ if UseRightToLeftAlignment then
+ ChangeBiDiModeAlignment(Alignment);
+
+ W := ClientWidth - FButtonWidth;
+
+ if W > 4 then
+ begin
+ SetRect(R, 1, 1, W - 1, ClientHeight - 1);
+ if TextMargin > 0 then
+ Inc(TextMargin);
+ X := 4 + TextMargin;
+ if not (FListVisible and (FDataListForm.FList.FSearchText <> '')) and not DrawList then
+ case Alignment of
+ taRightJustify:
+ X := W - Canvas.TextWidth(AText) - 6;
+ taCenter:
+ X := (W + TextMargin - Canvas.TextWidth(AText)) div 2;
+ end;
+ if BiDiMode = bdRightToLeft then
+ begin
+ Dec(X, TextMargin);
+ Inc(R.Left, FButtonWidth);
+ R.Right := ClientWidth;
+ end;
+ //if SysLocale.MiddleEast then
+ //begin
+ // TControlCanvas(Self.Canvas).UpdateTextFlags;
+ // Canvas.TextFlags := Self.Canvas.TextFlags;
+ //end;
+ Canvas.FillRect(R);
+ ImageRect := R;
+ if DrawList and (ListStyle = lsFixed) and (FDisplayValues <> nil) and
+ (FDisplayValues.Count > 0) then
+ begin
+ if IsEmpty then
+ begin
+ AText := DisplayEmpty;
+ Canvas.TextRect(ImageRect, X, R.Top + Max(0, (RectHeight(R) -
+ Canvas.TextHeight(AText)) div 2), AText);
+ end
+ else
+ PaintDisplayValues(Canvas, ImageRect, TextMargin);
+ end
+ else
+ Canvas.TextRect(ImageRect, X, R.Top + Max(0, (RectHeight(R) - Canvas.TextHeight(AText)) div 2), AText);
+
+ if Image <> nil then
+ begin
+ if BidiMode = bdRightToLeft then
+ ImageRect.Left := ImageRect.Right - (TextMargin + 2)
+ else
+ ImageRect.Right := ImageRect.Left + TextMargin + 2;
+ DrawPicture(Canvas, ImageRect, Image);
+ end
+ else if (ImgIndex > -1) and Assigned(ImageList) then
+ begin
+ if BidiMode = bdRightToLeft then
+ ImageRect.Left := ImageRect.Right - (TextMargin + 2)
+ else
+ ImageRect.Right := ImageRect.Left + TextMargin + 2;
+ DrawImage(Canvas, ImageRect, ImgIndex);
+ end;
+
+ if Selected then
+ Canvas.DrawFocusRect(R);
+ end;
+ SetRect(R, W, 0, ClientWidth, ClientHeight);
+ if BiDiMode = bdRightToLeft then
+ begin
+ R.Left := 0;
+ R.Right := FButtonWidth;
+ end;
+ if StyleServices.Enabled then
+ begin
+ if not FListActive or not Enabled or ReadOnly then
+ State := tcDropDownButtonDisabled
+ else
+ if FPressed or FListVisible then
+ State := tcDropDownButtonPressed
+ else
+ if FMouseOver and FMouseOverButton and not FListVisible then
+ State := tcDropDownButtonHot
+ else
+ State := tcDropDownButtonNormal;
+ Details := StyleServices.GetElementDetails(State);
+ StyleServices.DrawElement(Canvas.Handle, Details, R);
+ end
+ else
+ begin
+ if not FListActive or not Enabled or ReadOnly then
+ Flags := DFCS_SCROLLCOMBOBOX or DFCS_INACTIVE
+ else
+ if FPressed then // Classic Style doesn't keep the button pressed while the popup is visible
+ Flags := DFCS_SCROLLCOMBOBOX or DFCS_FLAT or DFCS_PUSHED
+ else
+ Flags := DFCS_SCROLLCOMBOBOX;
+ DrawFrameControl(Canvas.Handle, R, DFC_SCROLL, Flags);
+ end;
+end;
+
+procedure TJvDBLookupCombo.ResetField;
+begin
+ if FListVisible then
+ CloseUp(False);
+ inherited ResetField;
+ UpdateCurrentImage;
+ Invalidate;
+end;
+
+procedure TJvDBLookupCombo.StopTracking;
+begin
+ if FTracking then
+ begin
+ TrackButton(-1, -1);
+ FTracking := False;
+ MouseCapture := False;
+ end;
+end;
+
+procedure TJvDBLookupCombo.TrackButton(X, Y: Integer);
+var
+ NewState: Boolean;
+begin
+ NewState := PtInRect(GetDropDownButtonRect, Point(X, Y));
+ if FPressed <> NewState then
+ begin
+ FPressed := NewState;
+ InvalidateDropDownButton;
+ Repaint;
+ end;
+end;
+
+procedure TJvDBLookupCombo.UpdateDisplayEmpty(const AValue: string);
+begin
+ if Text = FDisplayEmpty then
+ inherited Text := AValue;
+end;
+
+procedure TJvDBLookupCombo.Click;
+begin
+ inherited Click;
+ Change;
+end;
+
+procedure TJvDBLookupCombo.CNKeyDown(var Msg: TLMKeyDown);
+begin
+ if not (csDesigning in ComponentState) then
+ begin
+ if TabSelects and IsDropDown and (Msg.Charcode = VK_TAB) then
+ Msg.Charcode := VK_RETURN;
+
+ if (Msg.CharCode in [VK_RETURN, VK_ESCAPE]) and FListVisible and
+ FLookupMode and FDataLink.DataSourceFixed then
+ begin
+ CloseUp(Msg.CharCode = VK_RETURN);
+ Msg.Result := 1;
+ Exit;
+ end;
+ end;
+ inherited;
+end;
+
+procedure TJvDBLookupCombo.FontChanged(Sender: TObject);
+begin
+ inherited FontChanged(Sender);
+ if not (csReading in ComponentState) then
+ Height := Max(Height, GetMinHeight);
+end;
+
+procedure TJvDBLookupCombo.MouseEnter;
+begin
+ if csDesigning in ComponentState then
+ Exit;
+ {Windows XP themes use hot track states, hence we have to update the drop down button.}
+ if StyleServices.Enabled and not FMouseOver then
+ begin
+ InvalidateFrame;
+ end;
+ FMouseOver := True;
+ inherited MouseEnter;
+end;
+
+procedure TJvDBLookupCombo.MouseLeave;
+begin
+ if FMouseOver then
+ begin
+ SetMouseOverButton(False);
+ InvalidateFrame; // border also needs a repaint
+ end;
+ FMouseOver := False;
+ inherited MouseLeave;
+end;
+
+procedure TJvDBLookupCombo.EnabledChanged;
+begin
+ inherited EnabledChanged;
+ Invalidate;
+end;
+
+procedure TJvDBLookupCombo.CMGetDataLink(var Msg: TLMessage);
+begin
+ Msg.Result := LRESULT(FDataLink);
+end;
+
+function TJvDBLookupCombo.GetDataLink: TDataLink;
+begin
+ Result := FDataLink;
+end;
+
+procedure TJvDBLookupCombo.WMCancelMode(var Msg: TLMessage);
+begin
+ StopTracking;
+ inherited;
+end;
+
+procedure TJvDBLookupCombo.WMSetCursor(var Msg: TLMSetCursor);
+var
+ Pt: TPoint;
+ R: TRect;
+begin
+ GetCursorPos(Pt);
+ R := ClientRect;
+ if PtInRect(Bounds(R.Right - FButtonWidth, R.Top, FButtonWidth, R.Bottom - R.Top), ScreenToClient(Pt)) then
+ {Windows.SetCursor(LoadCursor(0, IDC_ARROW))}
+ SetCursor(crArrow)
+ else
+ inherited;
+end;
+
+procedure TJvDBLookupCombo.BoundsChanged;
+begin
+ inherited BoundsChanged;
+ if not (csReading in ComponentState) and (Height < GetMinHeight) then
+ Height := GetMinHeight
+ else
+ begin
+ if csDesigning in ComponentState then
+ FDataListForm.SetBounds(0, Height + 1, 10, 10);
+ end;
+end;
+
+procedure TJvDBLookupCombo.CMBiDiModeChanged(var Msg: TLMessage);
+begin
+ inherited;
+ FDataListForm.FList.BiDiMode := BiDiMode;
+end;
+
+//=== { TJvPopupDataWindow } =================================================
+(*
+constructor TJvPopupDataWindow.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FEditor := TWinControl(AOwner);
+ Visible := False;
+ Parent := FEditor;
+ OnMouseUp := @PopupMouseUp;
+end;
+
+procedure TJvPopupDataWindow.InvalidateEditor;
+var
+ R: TRect;
+begin
+ {if FEditor is TJvCustomComboEdit then
+ with TJvComboEdit(FEditor) do
+ SetRect(R, 0, 0, ClientWidth - Button.Width - 2, ClientHeight + 1)
+ else}
+ R := FEditor.ClientRect;
+ {Windows.}InvalidateRect(FEditor.Handle, {$IFNDEF COMPILER12_UP}@{$ENDIF ~COMPILER12_UP}R, False);
+ UpdateWindow(FEditor.Handle);
+end;
+
+procedure TJvPopupDataWindow.Click;
+begin
+ inherited Click;
+ if Value <> '' then
+ with TJvDBLookupEdit(FEditor) do
+ if not (FChanging or ReadOnly) then
+ begin
+ FChanging := True;
+ try
+ Text := Self.DisplayValue;
+ if AutoSelect then
+ SelectAll;
+ finally
+ FChanging := False;
+ end;
+ end;
+ InvalidateEditor;
+end;
+
+procedure TJvPopupDataWindow.DisplayValueChanged;
+begin
+ if not FLockPosition then
+ if FListActive then
+ begin
+ if LocateDisplay then
+ FValue := FKeyField.AsString
+ else
+ begin
+ FLookupLink.DataSet.First;
+ FValue := EmptyValue;
+ end;
+ end
+ else
+ FValue := FEmptyValue;
+end;
+
+procedure TJvPopupDataWindow.KeyPress(var Key: Char);
+begin
+ inherited KeyPress(Key);
+ InvalidateEditor;
+end;
+
+procedure TJvPopupDataWindow.PopupMouseUp(Sender: TObject; Button: TMouseButton;
+ Shift: TShiftState; X, Y: Integer);
+begin
+ if Button = mbLeft then
+ CloseUp(PtInRect(ClientRect, Point(X, Y)));
+end;
+
+procedure TJvPopupDataWindow.CloseUp(Accept: Boolean);
+begin
+ if Assigned(FCloseUp) then
+ FCloseUp(Self, Accept);
+end;
+
+function TJvPopupDataWindow.GetPicture(Current, Empty: Boolean;
+ var TextMargin: Integer): TGraphic;
+begin
+ TextMargin := 0;
+ Result := nil;
+ if Assigned(FOnGetImage) then
+ FOnGetImage(FEditor, Empty, Result, TextMargin);
+end;
+
+procedure TJvPopupDataWindow.Hide;
+begin
+ SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
+ SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
+ Visible := False;
+end;
+
+procedure TJvPopupDataWindow.Show(Origin: TPoint);
+begin
+ SetWindowPos(Handle, HWND_TOP, Origin.X, Origin.Y, 0, 0,
+ SWP_NOACTIVATE or SWP_SHOWWINDOW or SWP_NOSIZE);
+ Visible := True;
+end;
+*)
+//=== { TJvDBLookupEdit } ====================================================
+(*
+constructor TJvDBLookupEdit.Create(AOwner: TComponent);
+begin
+ inherited Create(AOwner);
+ FDropDownCount := 8;
+ FPopupOnlyLocate := True;
+ ControlState := ControlState + [csCreating];
+ try
+ FPopup := TJvPopupDataWindow.Create(Self);
+ TJvPopupDataWindow(FPopup).OnCloseUp := PopupCloseUp;
+ GlyphKind := gkDropDown; { force update }
+ finally
+ ControlState := ControlState - [csCreating];
+ end;
+end;
+
+destructor TJvDBLookupEdit.Destroy;
+begin
+ if FPopup <> nil then
+ with TJvPopupDataWindow(FPopup) do
+ begin
+ OnCloseUp := nil;
+ OnGetImage := nil;
+ end;
+ FPopup.Free;
+ FPopup := nil;
+ inherited Destroy;
+end;
+
+procedure TJvDBLookupEdit.SetDropDownCount(Value: Integer);
+begin
+ if Value < 1 then
+ Value := 1;
+ if Value > 50 then
+ Value := 50;
+ FDropDownCount := Value;
+end;
+
+function TJvDBLookupEdit.GetListStyle: TLookupListStyle;
+begin
+ Result := TJvPopupDataWindow(FPopup).ListStyle;
+end;
+
+procedure TJvDBLookupEdit.SetListStyle(Value: TLookupListStyle);
+begin
+ TJvPopupDataWindow(FPopup).ListStyle := Value;
+end;
+
+function TJvDBLookupEdit.GetFieldsDelimiter: Char;
+begin
+ Result := TJvPopupDataWindow(FPopup).FieldsDelimiter;
+end;
+
+procedure TJvDBLookupEdit.SetFieldsDelimiter(Value: Char);
+begin
+ TJvPopupDataWindow(FPopup).FieldsDelimiter := Value;
+end;
+
+function TJvDBLookupEdit.GetLookupDisplay: string;
+begin
+ Result := TJvPopupDataWindow(FPopup).LookupDisplay;
+end;
+
+procedure TJvDBLookupEdit.SetLookupDisplay(const Value: string);
+begin
+ TJvPopupDataWindow(FPopup).LookupDisplay := Value;
+end;
+
+function TJvDBLookupEdit.GetDisplayIndex: Integer;
+begin
+ Result := TJvPopupDataWindow(FPopup).LookupDisplayIndex;
+end;
+
+procedure TJvDBLookupEdit.SetDisplayIndex(Value: Integer);
+begin
+ TJvPopupDataWindow(FPopup).LookupDisplayIndex := Value;
+end;
+
+function TJvDBLookupEdit.GetLookupField: string;
+begin
+ Result := TJvPopupDataWindow(FPopup).LookupField;
+end;
+
+procedure TJvDBLookupEdit.SetLookupField(const Value: string);
+begin
+ TJvPopupDataWindow(FPopup).LookupField := Value;
+end;
+
+function TJvDBLookupEdit.GetLookupSource: TDataSource;
+begin
+ Result := TJvPopupDataWindow(FPopup).LookupSource;
+end;
+
+procedure TJvDBLookupEdit.SetLookupSource(Value: TDataSource);
+begin
+ TJvPopupDataWindow(FPopup).LookupSource := Value;
+end;
+
+function TJvDBLookupEdit.GetOnGetImage: TGetImageEvent;
+begin
+ Result := TJvPopupDataWindow(FPopup).OnGetImage;
+end;
+
+procedure TJvDBLookupEdit.SetOnGetImage(Value: TGetImageEvent);
+begin
+ TJvPopupDataWindow(FPopup).OnGetImage := Value;
+end;
+
+function TJvDBLookupEdit.GetLookupValue: string;
+begin
+ TJvPopupDataWindow(FPopup).DisplayValue := Text;
+ Result := TJvPopupDataWindow(FPopup).Value;
+end;
+
+procedure TJvDBLookupEdit.SetLookupValue(const Value: string);
+begin
+ TJvPopupDataWindow(FPopup).Value := Value;
+
+ if Value = EmptyStr then
+ Text := EmptyStr
+ else
+ Text := TJvPopupDataWindow(FPopup).DisplayValue;
+end;
+
+procedure TJvDBLookupEdit.ShowPopup(Origin: TPoint);
+begin
+ TJvPopupDataWindow(FPopup).Show(Origin);
+end;
+
+procedure TJvDBLookupEdit.HidePopup;
+begin
+ TJvPopupDataWindow(FPopup).Hide;
+end;
+
+procedure TJvDBLookupEdit.PopupDropDown(DisableEdit: Boolean);
+begin
+ if not (ReadOnly or PopupVisible) then
+ begin
+ if Assigned(FOnDropDown) then
+ FOnDropDown(Self);
+ with TJvPopupDataWindow(FPopup) do
+ begin
+ Color := Self.Color;
+ Font := Self.Font;
+
+ {$IFDEF JVCLStylesEnabled}
+ if StyleServices.Enabled and TStyleManager.IsCustomStyleActive then
+ begin
+ Color := StyleServices.GetStyleColor(scComboBox);
+ Font.Color := StyleServices.GetStyleFontColor(sfComboBoxItemNormal);
+ end;
+ {$ENDIF JVCLStylesEnabled}
+
+ if FDropDownWidth > 0 then
+ Width := FDropDownWidth
+ else
+ if FDropDownWidth < 0 then
+ Width := Max(Self.Width, GetWindowWidth)
+ else
+ Width := Self.Width;
+ ReadOnly := Self.ReadOnly;
+ RowCount := FDropDownCount;
+ end;
+ end;
+ FBeforePopupValue := GetPopupValue;
+ inherited PopupDropDown(False);
+end;
+
+procedure TJvDBLookupEdit.KeyDown(var Key: Word; Shift: TShiftState);
+begin
+ if (Key in [VK_PRIOR, VK_NEXT, VK_UP, VK_DOWN]) and PopupVisible then
+ begin
+ TJvPopupDataWindow(FPopup).KeyDown(Key, Shift);
+ Key := 0;
+ end;
+ inherited KeyDown(Key, Shift);
+ FIgnoreChange := (SelLength > 0) or (Key = VK_BACK);
+ if not (PopupVisible or ReadOnly) and (Key in [VK_UP, VK_DOWN]) and
+ (Shift = []) then
+ begin
+ with TJvPopupDataWindow(FPopup) do
+ begin
+ KeyDown(Key, Shift);
+ if Value <> EmptyValue then
+ Key := 0;
+ end;
+ end;
+end;
+
+procedure TJvDBLookupEdit.KeyPress(var Key: Char);
+begin
+ inherited KeyPress(Key);
+ FIgnoreChange := (SelLength > 0) or (Key = Backspace);
+end;
+
+procedure TJvDBLookupEdit.Change;
+begin
+ if PopupOnlyLocate or PopupVisible then
+ inherited Change
+ else
+ begin
+ PopupChange;
+ DoChange;
+ end;
+end;
+
+procedure TJvDBLookupEdit.PopupChange;
+var
+ S: string;
+ Len: Integer;
+begin
+ if FChanging or FIgnoreChange or ReadOnly then
+ begin
+ FIgnoreChange := False;
+ Exit;
+ end;
+ FChanging := True;
+ try
+ S := Text;
+ if TJvPopupDataWindow(FPopup).SearchText(S) then
+ begin
+ Len := Length(Text);
+ Text := TJvPopupDataWindow(FPopup).DisplayValue;
+ SelStart := Len;
+ SelLength := Length(Text) - Len;
+ end
+ else
+ with TJvPopupDataWindow(FPopup) do
+ Value := EmptyValue;
+ finally
+ FChanging := False;
+ end;
+end;
+
+procedure TJvDBLookupEdit.SetPopupValue(const Value: Variant);
+begin
+ if VarIsNullEmpty(Value) then
+ TJvPopupDataWindow(FPopup).Value := TJvPopupDataWindow(FPopup).EmptyValue
+ else
+ TJvPopupDataWindow(FPopup).DisplayValue := Value;
+ FBeforePopupValue := GetPopupValue;
+end;
+
+function TJvDBLookupEdit.GetPopupValue: Variant;
+begin
+ with TJvPopupDataWindow(FPopup) do
+ if Value <> EmptyValue then
+ Result := DisplayValue
+ else
+ Result := Self.Text;
+end;
+
+function TJvDBLookupEdit.AcceptPopup(var Value: Variant): Boolean;
+begin
+ Result := Value <> FBeforePopupValue;
+ if Assigned(FOnCloseUp) then
+ FOnCloseUp(Self);
+end;
+
+function TJvDBLookupEdit.GetUseRecordCount: Boolean;
+begin
+ Result := TJvPopupDataWindow(FPopup).UseRecordCount;
+end;
+
+procedure TJvDBLookupEdit.SetUseRecordCount(const Value: Boolean);
+begin
+ TJvPopupDataWindow(FPopup).UseRecordCount := Value;
+end;
+*)
+
+end.
+
diff --git a/components/jvcllaz/run/JvDB/jvdbutils.pas b/components/jvcllaz/run/JvDB/jvdbutils.pas
new file mode 100644
index 000000000..49d7ccde1
--- /dev/null
+++ b/components/jvcllaz/run/JvDB/jvdbutils.pas
@@ -0,0 +1,986 @@
+{-----------------------------------------------------------------------------
+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: JvDBUtils.PAS, released on 2002-07-04.
+
+The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
+Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
+Copyright (c) 2001,2002 SGB Software
+All Rights Reserved.
+
+You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
+located at http://jvcl.delphi-jedi.org
+
+Contributors:
+tia
+
+Lazarus port: Michał Gawrycki
+
+Known Issues:
+-----------------------------------------------------------------------------}
+// $Id$
+
+unit JvDBUtils;
+
+{.$I jvcl.inc}
+
+interface
+
+uses
+ Variants, Classes, SysUtils, DB;
+
+type
+ TDropDownAlign = (daLeft, daRight, daCenter);
+
+ IJvDataControl = interface
+ ['{8B6910C8-D5FD-40BA-A427-FC54FE7B85E5}']
+ function GetDataLink: TDataLink;
+ end;
+
+ TJvDataLink = class(TDataLink)
+ protected
+ procedure FocusControl(Field: TFieldRef); overload; override;
+ procedure FocusControl(const Field: TField); reintroduce; overload; virtual;
+ end;
+
+ TCommit = (ctNone, ctStep, ctAll);
+ TJvDBProgressEvent = procedure(UserData: Integer; var Cancel: Boolean; Line: Integer) of object;
+
+ EJvScriptError = class(Exception)
+ private
+ FErrPos: Integer;
+ public
+ // The dummy parameter is only there for BCB compatibility so that
+ // when the hpp file gets generated, this constructor generates
+ // a C++ constructor that doesn't already exist
+ constructor Create(const AMessage: string; AErrPos: Integer; DummyForBCB: Integer = 0); overload;
+ property ErrPos: Integer read FErrPos;
+ end;
+
+ TJvLocateObject = class(TObject)
+ private
+ FDataSet: TDataSet;
+ FLookupField: TField;
+ FLookupValue: string;
+ FLookupExact: Boolean;
+ FCaseSensitive: Boolean;
+ FBookmark: TBookmark;
+ FIndexSwitch: Boolean;
+ procedure SetDataSet(Value: TDataSet);
+ protected
+ function MatchesLookup(Field: TField): Boolean;
+ procedure CheckFieldType(Field: TField); virtual;
+ procedure ActiveChanged; virtual;
+ function LocateFilter: Boolean; virtual;
+ function LocateKey: Boolean; virtual;
+ function LocateFull: Boolean; virtual;
+ function UseKey: Boolean; virtual;
+ function FilterApplicable: Boolean; virtual;
+ property LookupField: TField read FLookupField;
+ property LookupValue: string read FLookupValue;
+ property LookupExact: Boolean read FLookupExact;
+ property CaseSensitive: Boolean read FCaseSensitive;
+ property Bookmark: TBookmark read FBookmark write FBookmark;
+ public
+ function Locate(const KeyField, KeyValue: string; Exact,
+ ACaseSensitive: Boolean; DisableControls: Boolean = True;
+ RightTrimmedLookup: Boolean = False): Boolean;
+ property DataSet: TDataSet read FDataSet write SetDataSet;
+ property IndexSwitch: Boolean read FIndexSwitch write FIndexSwitch;
+ end;
+
+ TCreateLocateObject = function: TJvLocateObject;
+
+var
+ CreateLocateObject: TCreateLocateObject = nil;
+
+function CreateLocate(DataSet: TDataSet): TJvLocateObject;
+
+{ Utility routines }
+
+function ExtractFieldNameEx(const Fields: String;
+ var Pos: Integer): string;
+function IsDataSetEmpty(DataSet: TDataSet): Boolean;
+procedure RefreshQuery(Query: TDataSet);
+function DataSetSortedSearch(DataSet: TDataSet;
+ const Value, FieldName: string; CaseInsensitive: Boolean): Boolean;
+//function DataSetSectionName(DataSet: TDataSet): string;
+//procedure InternalSaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string);
+//procedure InternalRestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage;
+// const Path: string; RestoreVisible: Boolean);
+function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;
+ const KeyValues: Variant; Options: TLocateOptions): Boolean;
+(*
+procedure SaveFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile);
+procedure RestoreFieldsReg(DataSet: TDataSet; IniFile: TRegIniFile;
+ RestoreVisible: Boolean);
+*)
+//procedure SaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string = '');
+//procedure RestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string = '';
+// RestoreVisible: Boolean = True);
+procedure AssignRecord(Source, Dest: TDataSet; ByName: Boolean);
+function ConfirmDelete: Boolean;
+procedure ConfirmDataSetCancel(DataSet: TDataSet);
+procedure CheckRequiredField(Field: TField);
+procedure CheckRequiredFields(const Fields: array of TField);
+procedure GotoBookmarkEx(DataSet: TDataSet; const Bookmark: TBookmark; Mode: TResyncMode = [rmExact, rmCenter]; ForceScrollEvents: Boolean = False);
+
+{ SQL expressions }
+
+function DateToSQL(Value: TDateTime): string;
+function FormatSQLDateRange(Date1, Date2: TDateTime;
+ const FieldName: string): string;
+function FormatSQLDateRangeEx(Date1, Date2: TDateTime;
+ const FieldName: string): string;
+function FormatSQLNumericRange(const FieldName: string;
+ LowValue, HighValue, LowEmpty, HighEmpty: Double; Inclusive: Boolean): string;
+function StrMaskSQL(const Value: string): string;
+function FormatSQLCondition(const FieldName, AOperator, Value: string;
+ FieldType: TFieldType; Exact: Boolean): string;
+function FormatAnsiSQLCondition(const FieldName, AOperator, Value: string;
+ FieldType: TFieldType; Exact: Boolean): string;
+
+const
+ TrueExpr = '0=0';
+ {$NODEFINE TrueExpr}
+
+const
+ { Server Date formats}
+ sdfStandard16 = '''"''mm''/''dd''/''yyyy''"'''; {"mm/dd/yyyy"}
+ sdfStandard32 = '''''''dd/mm/yyyy'''''''; {'dd/mm/yyyy'}
+ sdfOracle = '"TO_DATE(''"dd/mm/yyyy"'', ''DD/MM/YYYY'')"';
+ sdfInterbase = '"CAST(''"mm"/"dd"/"yyyy"'' AS DATE)"';
+ sdfMSSQL = '"CONVERT(datetime, ''"mm"/"dd"/"yyyy"'', 103)"';
+
+const
+ ServerDateFmt: string = sdfStandard16;
+
+{.$NODEFINE ftNonTextTypes}
+(*$HPPEMIT 'namespace JvDBUtils'*)
+(*$HPPEMIT '{'*)
+(*$HPPEMIT '#define ftNonTextTypes (System::Set () \'*)
+(*$HPPEMIT ' << ftBytes << ftVarBytes << ftBlob << ftMemo << ftGraphic \'*)
+(*$HPPEMIT ' << ftFmtMemo << ftParadoxOle << ftDBaseOle << ftTypedBinary << ftCursor )'*)
+(*$HPPEMIT '}'*)
+
+type
+ Largeint = Longint;
+ {$NODEFINE Largeint}
+
+function NameDelimiter(C: Char): Boolean;
+function IsLiteral(C: Char): Boolean;
+procedure _DBError(const Msg: string);
+
+implementation
+
+uses
+ DBConst, Math, Controls, Forms, Dialogs, DateUtils,
+ JvJCLUtils, JvTypes, JvConsts, JvResources;
+
+resourcestring
+ SDeleteRecordQuestion = 'Delete record?';
+ SFieldTypeMismatch = 'Field type mismatch: %s';
+
+{ TJvDataLink }
+
+procedure TJvDataLink.FocusControl(Field: TFieldRef);
+begin
+ FocusControl(Field^);
+end;
+
+procedure TJvDataLink.FocusControl(const Field: TField);
+begin
+end;
+
+{ Utility routines }
+
+function NameDelimiter(C: Char): Boolean;
+begin
+ Result := CharInSet(C, [' ', ',', ';', ')', '.', Cr, Lf]);
+end;
+
+function IsLiteral(C: Char): Boolean;
+begin
+ Result := CharInSet(C, ['''', '"']);
+end;
+
+procedure _DBError(const Msg: string);
+begin
+ DatabaseError(Msg);
+end;
+
+constructor EJvScriptError.Create(const AMessage: string; AErrPos: Integer; DummyForBCB: Integer);
+begin
+ inherited Create(AMessage);
+ FErrPos := AErrPos;
+end;
+
+// (rom) better use Windows dialogs which are localized
+
+function ConfirmDelete: Boolean;
+begin
+ Screen.Cursor := crDefault;
+ Result := MessageDlg(SDeleteRecordQuestion, mtConfirmation,
+ [mbYes, mbNo], 0) = mrYes;
+end;
+
+procedure ConfirmDataSetCancel(DataSet: TDataSet);
+begin
+ if DataSet.State in [dsEdit, dsInsert] then
+ begin
+ DataSet.UpdateRecord;
+ if DataSet.Modified then
+ begin
+ case MessageDlg(RsConfirmSave, mtConfirmation, mbYesNoCancel, 0) of
+ mrYes:
+ DataSet.Post;
+ mrNo:
+ DataSet.Cancel;
+ else
+ SysUtils.Abort;
+ end;
+ end
+ else
+ DataSet.Cancel;
+ end;
+end;
+
+function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
+begin
+ Result := False;
+ if ADataSet.Active and (ABookmark <> nil) and not (ADataSet.Bof and ADataSet.Eof) and
+ ADataSet.BookmarkValid(ABookmark) then
+ try
+ ADataSet.GotoBookmark(ABookmark);
+ Result := True;
+ except
+ end;
+end;
+
+{ Refresh Query procedure }
+
+procedure RefreshQuery(Query: TDataSet);
+var
+ BookMk: TBookmark;
+begin
+ Query.DisableControls;
+ try
+ if Query.Active then
+ BookMk := Query.GetBookmark
+ else
+ BookMk := nil;
+ try
+ Query.Close;
+ Query.Open;
+ SetToBookmark(Query, BookMk);
+ finally
+ if BookMk <> nil then
+ Query.FreeBookmark(BookMk);
+ end;
+ finally
+ Query.EnableControls;
+ end;
+end;
+
+procedure TJvLocateObject.SetDataSet(Value: TDataSet);
+begin
+ ActiveChanged;
+ FDataSet := Value;
+end;
+
+function TJvLocateObject.LocateFull: Boolean;
+begin
+ Result := False;
+ DataSet.First;
+ while not DataSet.Eof do
+ begin
+ if MatchesLookup(FLookupField) then
+ begin
+ Result := True;
+ Break;
+ end;
+ DataSet.Next;
+ end;
+end;
+
+function TJvLocateObject.LocateKey: Boolean;
+begin
+ Result := False;
+end;
+
+function TJvLocateObject.FilterApplicable: Boolean;
+begin
+ Result := FLookupField.FieldKind in [fkData, fkInternalCalc];
+end;
+
+function TJvLocateObject.LocateFilter: Boolean;
+var
+ SaveCursor: TCursor;
+ Options: TLocateOptions;
+ Value: Variant;
+begin
+ SaveCursor := Screen.Cursor;
+ Screen.Cursor := crHourGlass;
+ try
+ Options := [];
+ if not FCaseSensitive then
+ Include(Options, loCaseInsensitive);
+ if not FLookupExact then
+ Include(Options, loPartialKey);
+ if FLookupValue = '' then
+ VarClear(Value)
+ else
+ Value := FLookupValue;
+ Result := DataSet.Locate(FLookupField.FieldName, Value, Options);
+ finally
+ Screen.Cursor := SaveCursor;
+ end;
+end;
+
+procedure TJvLocateObject.CheckFieldType(Field: TField);
+begin
+end;
+
+function TJvLocateObject.Locate(const KeyField, KeyValue: string;
+ Exact, ACaseSensitive: Boolean; DisableControls: Boolean; RightTrimmedLookup: Boolean): Boolean;
+var
+ LookupKey: TField;
+
+ function IsStringType(FieldType: TFieldType): Boolean;
+ const
+ cStringTypes = [ftString, ftWideString];
+ begin
+ Result := FieldType in cStringTypes;
+ end;
+
+begin
+ if DataSet = nil then
+ begin
+ Result := False;
+ Exit;
+ end;
+ DataSet.CheckBrowseMode;
+ LookupKey := DataSet.FieldByName(KeyField);
+ DataSet.CursorPosChanged;
+ FLookupField := LookupKey;
+ if RightTrimmedLookup then
+ FLookupValue := TrimRight(KeyValue)
+ else
+ FLookupValue := KeyValue;
+ FLookupExact := Exact;
+ FCaseSensitive := ACaseSensitive;
+ if not IsStringType(FLookupField.DataType) then
+ begin
+ FCaseSensitive := True;
+ try
+ CheckFieldType(FLookupField);
+ except
+ Result := False;
+ Exit;
+ end;
+ end
+ else
+ FCaseSensitive := ACaseSensitive;
+ if DisableControls then
+ DataSet.DisableControls;
+ try
+ FBookmark := DataSet.GetBookmark;
+ try
+ Result := MatchesLookup(FLookupField);
+ if not Result then
+ begin
+ if UseKey then
+ Result := LocateKey
+ else
+ begin
+ if FilterApplicable then
+ Result := LocateFilter
+ else
+ Result := LocateFull;
+ end;
+ if not Result then
+ SetToBookmark(DataSet, FBookmark);
+ end;
+ finally
+ FLookupValue := '';
+ FLookupField := nil;
+ DataSet.FreeBookmark(FBookmark);
+ FBookmark := nil;
+ end;
+ finally
+ if DisableControls then
+ DataSet.EnableControls;
+ end;
+end;
+
+function TJvLocateObject.UseKey: Boolean;
+begin
+ Result := False;
+end;
+
+procedure TJvLocateObject.ActiveChanged;
+begin
+end;
+
+function TJvLocateObject.MatchesLookup(Field: TField): Boolean;
+var
+ Temp: string;
+begin
+ Temp := Field.AsString;
+ if not LookupExact then
+ SetLength(Temp, Min(Length(FLookupValue), Length(Temp)));
+ if CaseSensitive then
+ Result := AnsiSameStr(Temp, LookupValue)
+ else
+ Result := AnsiSameText(Temp, LookupValue);
+end;
+
+function CreateLocate(DataSet: TDataSet): TJvLocateObject;
+begin
+ if Assigned(CreateLocateObject) then
+ Result := CreateLocateObject()
+ else
+ Result := TJvLocateObject.Create;
+ if (Result <> nil) and (DataSet <> nil) then
+ Result.DataSet := DataSet;
+end;
+
+{ DataSet locate routines }
+
+function DataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;
+ const KeyValues: Variant; Options: TLocateOptions): Boolean;
+var
+ FieldCount: Integer;
+ Fields: TList;
+ Bookmark: TBookmark;
+
+ function CompareField(Field: TField; const Value: Variant): Boolean;
+ var
+ S: string;
+ begin
+ if Field.DataType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then
+ begin
+ if Value = Null then
+ Result := Field.IsNull
+ else
+ begin
+ S := Field.AsString;
+ if loPartialKey in Options then
+ Delete(S, Length(Value) + 1, MaxInt);
+ if loCaseInsensitive in Options then
+ Result := AnsiSameText(S, Value)
+ else
+ Result := AnsiSameStr(S, Value);
+ end;
+ end
+ else
+ Result := (Field.Value = Value);
+ end;
+
+ function CompareRecord: Boolean;
+ var
+ I: Integer;
+ begin
+ // Works with the KeyValues variant like TCustomClientDataSet.LocateRecord
+ if (FieldCount = 1) and not VarIsArray(KeyValues) then
+ Result := CompareField(TField(Fields[0]), KeyValues)
+ else
+ begin
+ Result := True;
+ for I := 0 to FieldCount - 1 do
+ Result := Result and CompareField(TField(Fields[I]), KeyValues[I]);
+ end;
+ end;
+
+begin
+ Result := False;
+ DataSet.CheckBrowseMode;
+ if DataSet.IsEmpty then
+ Exit;
+ Fields := TList.Create;
+ try
+ DataSet.GetFieldList(Fields, KeyFields);
+ FieldCount := Fields.Count;
+ Result := CompareRecord;
+ if Result then
+ Exit;
+ DataSet.DisableControls;
+ try
+ Bookmark := DataSet.Bookmark;
+ try
+ DataSet.First;
+ while not DataSet.Eof do
+ begin
+ Result := CompareRecord;
+ if Result then
+ Break;
+ DataSet.Next;
+ end;
+ finally
+ if not Result and DataSet.BookmarkValid(TBookmark(Bookmark)) then
+ DataSet.Bookmark := Bookmark;
+ end;
+ finally
+ DataSet.EnableControls;
+ end;
+ finally
+ Fields.Free;
+ end;
+end;
+
+{ DataSetSortedSearch. Navigate on sorted DataSet routine. }
+
+function DataSetSortedSearch(DataSet: TDataSet; const Value,
+ FieldName: string; CaseInsensitive: Boolean): Boolean;
+var
+ L, H, I: Longint;
+ CurrentPos: Longint;
+ CurrentValue: string;
+ BookMk: TBookmark;
+ Field: TField;
+
+ function UpStr(const Value: string): string;
+ begin
+ if CaseInsensitive then
+ Result := AnsiUpperCase(Value)
+ else
+ Result := Value;
+ end;
+
+ function GetCurrentStr: string;
+ begin
+ Result := Field.AsString;
+ if Length(Result) > Length(Value) then
+ SetLength(Result, Length(Value));
+ Result := UpStr(Result);
+ end;
+
+begin
+ Result := False;
+ if DataSet = nil then
+ Exit;
+ Field := DataSet.FindField(FieldName);
+ if Field = nil then
+ Exit;
+ if Field.DataType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then
+ begin
+ DataSet.DisableControls;
+ BookMk := DataSet.GetBookmark;
+ try
+ L := 0;
+ DataSet.First;
+ CurrentPos := 0;
+ H := DataSet.RecordCount - 1;
+ if Value <> '' then
+ begin
+ while L <= H do
+ begin
+ I := (L + H) shr 1;
+ if I <> CurrentPos then
+ DataSet.MoveBy(I - CurrentPos);
+ CurrentPos := I;
+ CurrentValue := GetCurrentStr;
+ if UpStr(Value) > CurrentValue then
+ L := I + 1
+ else
+ begin
+ H := I - 1;
+ if UpStr(Value) = CurrentValue then
+ Result := True;
+ end;
+ end;
+ if Result then
+ begin
+ if L <> CurrentPos then
+ DataSet.MoveBy(L - CurrentPos);
+ while (L < DataSet.RecordCount) and
+ (UpStr(Value) <> GetCurrentStr) do
+ begin
+ Inc(L);
+ DataSet.MoveBy(1);
+ end;
+ end;
+ end
+ else
+ Result := True;
+ if not Result then
+ SetToBookmark(DataSet, BookMk);
+ finally
+ DataSet.FreeBookmark(BookMk);
+ DataSet.EnableControls;
+ end;
+ end
+ else
+ DatabaseErrorFmt(SFieldTypeMismatch, [Field.DisplayName]);
+end;
+
+{ Save and restore DataSet Fields layout }
+
+//function DataSetSectionName(DataSet: TDataSet): string;
+//begin
+// if (DataSet.Owner <> nil) and (DataSet.Owner is TCustomForm) then
+// Result := GetDefaultSection(DataSet.Owner as TCustomForm)
+// else
+// Result := DataSet.Name;
+//end;
+//
+//function CheckSection(DataSet: TDataSet; const Section: string): string;
+//begin
+// Result := Section;
+// if Result = '' then
+// Result := DataSetSectionName(DataSet);
+//end;
+//
+//procedure InternalSaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string);
+//var
+// I: Integer;
+// Field: TField;
+//begin
+// AppStorage.BeginUpdate;
+// try
+// for I := 0 to DataSet.FieldCount - 1 do
+// begin
+// Field := DataSet.Fields[i];
+// AppStorage.WriteString(AppStorage.ConcatPaths([CheckSection(DataSet, Path),
+// DataSet.Name + Field.FieldName]),
+// Format('%d,%d,%d', [Field.Index, Field.DisplayWidth, Integer(Field.Visible)]));
+// end;
+// finally
+// AppStorage.EndUpdate;
+// end;
+//end;
+//
+//procedure InternalRestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage;
+// const Path: string; RestoreVisible: Boolean);
+//type
+// TFieldInfo = record
+// Field: TField;
+// EndIndex: Integer;
+// end;
+// TFieldArray = array of TFieldInfo;
+//const
+// Delims = [' ', ','];
+//var
+// I, J: Integer;
+// S: string;
+// FieldArray: TFieldArray;
+//begin
+// SetLength(FieldArray, DataSet.FieldCount);
+// AppStorage.BeginUpdate;
+// try
+// for I := 0 to DataSet.FieldCount - 1 do
+// begin
+// S := AppStorage.ReadString(AppStorage.ConcatPaths([CheckSection(DataSet, Path),
+// DataSet.Name + DataSet.Fields[I].FieldName]), '');
+// FieldArray[I].Field := DataSet.Fields[I];
+// FieldArray[I].EndIndex := DataSet.Fields[I].Index;
+// if S <> '' then
+// begin
+// FieldArray[I].EndIndex := StrToIntDef(ExtractWord(1, S, Delims),
+// FieldArray[I].EndIndex);
+// DataSet.Fields[I].DisplayWidth := StrToIntDef(ExtractWord(2, S, Delims),
+// DataSet.Fields[I].DisplayWidth);
+// if RestoreVisible then
+// DataSet.Fields[I].Visible := Boolean(StrToIntDef(ExtractWord(3, S, Delims),
+// Integer(DataSet.Fields[I].Visible)));
+// end;
+// end;
+// for I := 0 to DataSet.FieldCount - 1 do
+// begin
+// for J := 0 to DataSet.FieldCount - 1 do
+// begin
+// if FieldArray[J].EndIndex = I then
+// begin
+// FieldArray[J].Field.Index := FieldArray[J].EndIndex;
+// Break;
+// end;
+// end;
+// end;
+// finally
+// AppStorage.EndUpdate;
+// FieldArray := nil;
+// end;
+//end;
+//
+//procedure SaveFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string);
+//begin
+// InternalSaveFields(DataSet, AppStorage, AppStorage.ConcatPaths([Path, DataSetSectionName(DataSet)]));
+//end;
+//
+//procedure RestoreFields(DataSet: TDataSet; AppStorage: TJvCustomAppStorage; const Path: string;
+// RestoreVisible: Boolean);
+//begin
+// InternalRestoreFields(DataSet, AppStorage, AppStorage.ConcatPaths([DataSetSectionName(DataSet)]),
+// RestoreVisible);
+//end;
+
+function ExtractFieldNameEx(const Fields: String;
+ var Pos: Integer): string;
+begin
+ Result := ExtractFieldName(Fields, Pos);
+end;
+
+function IsDataSetEmpty(DataSet: TDataSet): Boolean;
+begin
+ Result := (not DataSet.Active) or (DataSet.Eof and DataSet.Bof);
+end;
+
+{ SQL expressions }
+
+function DateToSQL(Value: TDateTime): string;
+begin
+ Result := IntToStr(Trunc(Value));
+end;
+
+function FormatSQLDateRange(Date1, Date2: TDateTime;
+ const FieldName: string): string;
+begin
+ Result := TrueExpr;
+ if (Date1 = Date2) and (Date1 <> NullDate) then
+ begin
+ Result := Format('%s = %s', [FieldName, FormatDateTime(ServerDateFmt,
+ Date1)]);
+ end
+ else
+ if (Date1 <> NullDate) or (Date2 <> NullDate) then
+ begin
+ if Date1 = NullDate then
+ Result := Format('%s < %s', [FieldName,
+ FormatDateTime(ServerDateFmt, IncDay(Date2, 1))])
+ else
+ if Date2 = NullDate then
+ Result := Format('%s > %s', [FieldName,
+ FormatDateTime(ServerDateFmt, IncDay(Date1, -1))])
+ else
+ Result := Format('(%s < %s) AND (%s > %s)',
+ [FieldName, FormatDateTime(ServerDateFmt, IncDay(Date2, 1)),
+ FieldName, FormatDateTime(ServerDateFmt, IncDay(Date1, -1))]);
+ end;
+end;
+
+function FormatSQLDateRangeEx(Date1, Date2: TDateTime;
+ const FieldName: string): string;
+begin
+ Result := TrueExpr;
+ if (Date1 <> NullDate) or (Date2 <> NullDate) then
+ begin
+ if Date1 = NullDate then
+ Result := Format('%s < %s', [FieldName,
+ FormatDateTime(ServerDateFmt, IncDay(Date2, 1))])
+ else
+ if Date2 = NullDate then
+ Result := Format('%s >= %s', [FieldName,
+ FormatDateTime(ServerDateFmt, Date1)])
+ else
+ Result := Format('(%s < %s) AND (%s >= %s)',
+ [FieldName, FormatDateTime(ServerDateFmt, IncDay(Date2, 1)),
+ FieldName, FormatDateTime(ServerDateFmt, Date1)]);
+ end;
+end;
+
+function FormatSQLNumericRange(const FieldName: string;
+ LowValue, HighValue, LowEmpty, HighEmpty: Double; Inclusive: Boolean): string;
+const
+ Operators: array[Boolean, 1..2] of string[2] = (('>', '<'), ('>=', '<='));
+begin
+ Result := TrueExpr;
+ if (LowValue = HighValue) and (LowValue <> LowEmpty) then
+ Result := Format('%s = %g', [FieldName, LowValue])
+ else
+ if (LowValue <> LowEmpty) or (HighValue <> HighEmpty) then
+ begin
+ if LowValue = LowEmpty then
+ Result := Format('%s %s %g', [FieldName, Operators[Inclusive, 2], HighValue])
+ else
+ if HighValue = HighEmpty then
+ Result := Format('%s %s %g', [FieldName, Operators[Inclusive, 1], LowValue])
+ else
+ Result := Format('(%s %s %g) AND (%s %s %g)',
+ [FieldName, Operators[Inclusive, 2], HighValue,
+ FieldName, Operators[Inclusive, 1], LowValue]);
+ end;
+end;
+
+function StrMaskSQL(const Value: string): string;
+begin
+ if (Pos('*', Value) = 0) and (Pos('?', Value) = 0) and (Value <> '') then
+ Result := '*' + Value + '*'
+ else
+ Result := Value;
+end;
+
+function FormatSQLCondition(const FieldName, AOperator, Value: string;
+ FieldType: TFieldType; Exact: Boolean): string;
+var
+ EmptyValue: Boolean;
+ FieldValue: string;
+ DateValue: TDateTime;
+ LogicOperator: string;
+begin
+ FieldValue := '';
+ DateValue := NullDate;
+ Exact := Exact or not (FieldType in
+ [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}, ftDate, ftTime, ftDateTime]);
+ if FieldType in [ftDate, ftTime, ftDateTime] then
+ begin
+ DateValue := StrToDateDef(Value, NullDate);
+ EmptyValue := (DateValue = NullDate);
+ FieldValue := FormatDateTime(ServerDateFmt, DateValue);
+ end
+ else
+ begin
+ FieldValue := Value;
+ EmptyValue := FieldValue = '';
+ if not (Exact or EmptyValue) then
+ FieldValue := ReplaceStr(ReplaceStr(StrMaskSQL(FieldValue),
+ '*', '%'), '?', '_');
+ if FieldType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then
+ FieldValue := '''' + FieldValue + '''';
+ end;
+ LogicOperator := AOperator;
+ if LogicOperator = '' then
+ begin
+ if Exact then
+ LogicOperator := '='
+ else
+ begin
+ if FieldType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}] then
+ LogicOperator := 'LIKE'
+ else
+ LogicOperator := '>=';
+ end;
+ end;
+ if EmptyValue then
+ Result := TrueExpr
+ else
+ if (FieldType = ftDateTime) and Exact then
+ begin
+ DateValue := IncDay(DateValue, 1);
+ Result := Format('(%s >= %s) and (%s < %s)', [FieldName, FieldValue,
+ FieldName, FormatDateTime(ServerDateFmt, DateValue)]);
+ end
+ else
+ Result := Format('%s %s %s', [FieldName, LogicOperator, FieldValue]);
+end;
+
+function FormatAnsiSQLCondition(const FieldName, AOperator, Value: string;
+ FieldType: TFieldType; Exact: Boolean): string;
+var
+ S, Esc: string;
+begin
+ Esc := '';
+ if not Exact and (FieldType in [ftString{$IFDEF UNICODE}, ftWideString{$ENDIF UNICODE}]) then
+ begin
+ S := ReplaceStr(ReplaceStr(ReplaceStr(Value, '/', '//'),
+ '_', '/_'), '%', '/%');
+ if S <> Value then
+ Esc := ' ESCAPE''/''';
+ end
+ else
+ S := Value;
+ Result := FormatSQLCondition(FieldName, AOperator, S, FieldType, Exact) + Esc;
+end;
+
+procedure CheckRequiredField(Field: TField);
+begin
+ if not Field.ReadOnly and not Field.Calculated and Field.IsNull then
+ begin
+ Field.FocusControl;
+ DatabaseErrorFmt(SNeedField, [Field.DisplayName]);
+ end;
+end;
+
+procedure CheckRequiredFields(const Fields: array of TField);
+var
+ I: Integer;
+begin
+ for I := Low(Fields) to High(Fields) do
+ CheckRequiredField(Fields[I]);
+end;
+
+type
+ TDataSetAccess = class(TDataSet);
+
+procedure GotoBookmarkEx(DataSet: TDataSet; const Bookmark: TBookmark; Mode: TResyncMode; ForceScrollEvents: Boolean);
+var
+ DS: TDataSetAccess;
+begin
+ if (DataSet <> nil) and (Bookmark <> nil) then
+ begin
+ DS := TDataSetAccess(DataSet);
+ DS.CheckBrowseMode;
+ if ForceScrollEvents or (rmCenter in Mode) then DS.DoBeforeScroll;
+ DS.InternalGotoBookmark(Pointer(Bookmark));
+ DS.Resync(Mode);
+ if ForceScrollEvents or (rmCenter in Mode) then DS.DoAfterScroll;
+ end;
+end;
+
+procedure AssignRecord(Source, Dest: TDataSet; ByName: Boolean);
+var
+ I: Integer;
+ F, FSrc: TField;
+begin
+ if not (Dest.State in dsEditModes) then
+ _DBError(SNotEditing);
+ if ByName then
+ begin
+ for I := 0 to Source.FieldCount - 1 do
+ begin
+ F := Dest.FindField(Source.Fields[I].FieldName);
+ FSrc := Source.Fields[i];
+ if (F <> nil) and (F.DataType <> ftAutoInc) then
+ begin
+ if FSrc.IsNull then
+ F.Value := FSrc.Value
+ else
+ case F.DataType of
+ ftString: F.AsString := FSrc.AsString;
+ ftInteger: F.AsInteger := FSrc.AsInteger;
+ ftBoolean: F.AsBoolean := FSrc.AsBoolean;
+ ftFloat: F.AsFloat := FSrc.AsFloat;
+ ftCurrency: F.AsCurrency := FSrc.AsCurrency;
+ ftDate: F.AsDateTime := FSrc.AsDateTime;
+ ftDateTime: F.AsDateTime := FSrc.AsDateTime;
+ else
+ F.Value := FSrc.Value;
+ end;
+ end;
+ end;
+ end
+ else
+ begin
+ for I := 0 to Min(Source.FieldDefs.Count - 1, Dest.FieldDefs.Count - 1) do
+ begin
+ F := Dest.FindField(Dest.FieldDefs[I].Name);
+ FSrc := Source.FindField(Source.FieldDefs[I].Name);
+ if (F <> nil) and (FSrc <> nil) and (F.DataType <> ftAutoInc) then
+ begin
+ if FSrc.IsNull then
+ F.Value := FSrc.Value
+ else
+ case F.DataType of
+ ftString: F.AsString := FSrc.AsString;
+ ftInteger: F.AsInteger := FSrc.AsInteger;
+ ftBoolean: F.AsBoolean := FSrc.AsBoolean;
+ ftFloat: F.AsFloat := FSrc.AsFloat;
+ ftCurrency: F.AsCurrency := FSrc.AsCurrency;
+ ftDate: F.AsDateTime := FSrc.AsDateTime;
+ ftDateTime: F.AsDateTime := FSrc.AsDateTime;
+ else
+ F.Value := FSrc.Value;
+ end;
+ end;
+ end;
+ end;
+end;
+
+end.
+