From ace2f64cb8ac0bdf43640ec3a4ed4f2de3657e42 Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Mon, 22 Apr 2019 09:50:00 +0000 Subject: [PATCH] JVCLLaz: Add TJvDBLookupList and TJvDBLookupCombo. Issue #34322, patch by Michal Gawrycki. git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6851 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- components/jvcllaz/design/JvDB/JvDBReg.pas | 5 +- .../examples/JvDBLookup/JvDBLookupDemo.lpi | 73 + .../examples/JvDBLookup/JvDBLookupDemo.lpr | 22 + .../jvcllaz/examples/JvDBLookup/main.lfm | 335 ++ .../jvcllaz/examples/JvDBLookup/main.pas | 85 + components/jvcllaz/packages/JvDBLazR.lpk | 10 +- components/jvcllaz/resource/jvdbreg.res | Bin 8656 -> 12060 bytes components/jvcllaz/run/JvCore/JvTypes.pas | 2 + components/jvcllaz/run/JvDB/jvdblookup.pas | 4071 +++++++++++++++++ components/jvcllaz/run/JvDB/jvdbutils.pas | 986 ++++ 10 files changed, 5586 insertions(+), 3 deletions(-) create mode 100644 components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpi create mode 100644 components/jvcllaz/examples/JvDBLookup/JvDBLookupDemo.lpr create mode 100644 components/jvcllaz/examples/JvDBLookup/main.lfm create mode 100644 components/jvcllaz/examples/JvDBLookup/main.pas create mode 100644 components/jvcllaz/run/JvDB/jvdblookup.pas create mode 100644 components/jvcllaz/run/JvDB/jvdbutils.pas 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 @@ + + + + + + + + + + + + <Scaled Value="True"/> + <ResourceType Value="res"/> + <UseXPManifest Value="True"/> + <XPManifest> + <DpiAware Value="True"/> + </XPManifest> + <Icon Value="0"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <FormatVersion Value="2"/> + <Modes Count="0"/> + </RunParams> + <RequiredPackages Count="3"> + <Item1> + <PackageName Value="JvDBLazR"/> + </Item1> + <Item2> + <PackageName Value="FCL"/> + </Item2> + <Item3> + <PackageName Value="LCL"/> + </Item3> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="JvDBLookupDemo.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="main.pas"/> + <IsPartOfProject Value="True"/> + <ComponentName Value="Form1"/> + <HasResources Value="True"/> + <ResourceBaseClass Value="Form"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="..\..\bin\JvDBLookupDemo"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + <Linking> + <Options> + <Win32> + <GraphicApplication Value="True"/> + </Win32> + </Options> + </Linking> + </CompilerOptions> +</CONFIG> 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 @@ "/> <License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/> <Version Major="1" Release="4"/> - <Files Count="4"> + <Files Count="6"> <Item1> <Filename Value="..\run\JvDB\JvDBHTLabel.pas"/> <UnitName Value="JvDBHTLabel"/> @@ -36,6 +36,14 @@ <Filename Value="..\run\JvDB\JvDBControls.pas"/> <UnitName Value="JvDBControls"/> </Item4> + <Item5> + <Filename Value="..\run\JvDB\jvdblookup.pas"/> + <UnitName Value="JvDBLookup"/> + </Item5> + <Item6> + <Filename Value="..\run\JvDB\jvdbutils.pas"/> + <UnitName Value="JvDBUtils"/> + </Item6> </Files> <RequiredPkgs Count="4"> <Item1> diff --git a/components/jvcllaz/resource/jvdbreg.res b/components/jvcllaz/resource/jvdbreg.res index c1deb5bb5794c6237c91641ba010f8c20edaa566..3a52074e14adb55331cc6e8107cc62dee0478bb7 100644 GIT binary patch delta 1199 zcmbVMOG*Pl5UrNZ3<$xE3gRLs5aKE>bXtrXH6dcuo#GvGfVqM)Tft5CezF!kf*0`s zgOK)BRZowGaiKK>39nwgs;+*_d;k9Wc3`^C!-vFlXCKKVDc%yhy-!5mFVQ(2(<L3! z0S#z`=Y%fkl=}EL1U3Ro0|H}PJayLcEXz<SF>igg_;tWI$XkhsBVh%v_$}o-msuog ze#E&xBbBjpz@qQ06TbC6XDLY_=Qx2Tv0$#jI3hNH9;#?B;I29VYt=Zp>a^ik`D7?n zB6IUJO(_#0GE+*!sGdC4I4430S_Pb@#+VYUI-uhmrKu^)k}$6ZHlwij!0UwIIp{16 z5s-MhvSU^elohco(c%>=EGS?Nl*oKkD$e}Sy@z=t9M;7xdOhjqT#>X_*g;#nnBaE@ z4d{r*aF+($b7qUj&U((59wNGg^%)P-MI2|~6V&|54dR}PuV!Eu^0}?8ys+pVVhiLf zw&0$+;HP_H18jsZy>d?+=qJt_)f33&P~gKo+*703J;*J(Cl>tKJ?sc<Lhk*$dlYYQ pk0cu0!+4W><gUbP|8>tzd&hL|h8we&_Hv4k((9^xo31t|$rs8yXzTz0 delta 54 zcmbOecfomr52L_F-}!8e0-N8m6|+rVBW1xTFws|X^FJvrb`VQ>vyM^?P<o?p0L$i| HI?7A{_*)S; 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<TFieldType, ftUnknown, ftCursor> () \'*) +(*$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. +