trunk/ibcontrols/IBLookupComboEditBox.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit IBLookupComboEditBox;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
  ExtCtrls,  DB, StdCtrls,  LCLVersion, IBDynamicInterfaces;

type

  {TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
   of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
   to revise the available list and restrict it to items that are prefixed by the
   typed text (either case sensitive or case insenstive). Autoinsert allows a
   newly typed entry to be added to the list dataset and included in the available
   list items.    }

  TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
  TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;

  TIBLookupComboEditBox = class;

  { TIBLookupComboDataLink }

  TIBLookupComboDataLink = class(TDataLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure ActiveChanged; override;
    {$if lcl_fullversion < 2000000}
    procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
    {$endif}
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;

  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox,IDynamicSQLComponent)
  private
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FOnSetParams : TOnSetParams;
    FOnUpdateSQL : TOnUpdateSQL;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: boolean;
    FLastKeyValue: variant;
    FCurText: string;
    FModified: boolean;
    FCurListDataset: TDataset;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListDatset : TDataset;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure ListDatasetChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
    procedure ValidateListField;
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    {$if lcl_fullversion >= 2000002}
    {Deferred update changes in Lazarus 2.0 stop the combo box working when
     the datasource is nil. We thus have to reverse out the changes :(}
    function DoEdit: boolean; override;
    procedure Change; override;
    procedure CloseUp; override;
    procedure Select; override;
    {$ifend}
    {$if lcl_fullversion = 2000002}
    procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
    {$ifend}
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    procedure UpdateShowing; override;
    procedure UpdateData(Sender: TObject); override;
    {IDynamicSQLComponent}
    procedure UpdateSQL(SQLEditor: IDynamicSQLEditor);
    procedure SetParams(SQLParamProvider: IDynamicSQLParam);
  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    procedure EditingDone; override;
    property ListDataSet: TDataset read GetListDatset;
  published
    { Published declarations }
    property AutoInsert: boolean read FAutoInsert write FAutoInsert;
    property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
    property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
             write SetAutoCompleteText;
    property ItemHeight;
    property ItemWidth;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
    property RelationName: string read FRelationName write FRelationName;
    property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
    property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
    property OnUpdateSQL: TOnUpdateSQL read FOnUpdateSQL write FOnUpdateSQL;
    property OnSetParams: TOnSetParams read FOnSetParams write FOnSetParams;
  end;


implementation

uses Variants, LCLProc, LazUTF8;

resourcestring
  ibxeListFieldNotFound = 'ListField Name is not a valid dataset column name (%s)';


{ TIBLookupComboDataLink }

procedure TIBLookupComboDataLink.ActiveChanged;
begin
  FOwner.ActiveChanged(self)
end;

{$if lcl_fullversion < 2000000}
procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
begin
  inherited DataEvent(Event, Info);
  if Event = deLayoutChange then
   FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
end;
{$endif}

procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
begin
  FOwner.RecordChanged(self,Field);
end;

procedure TIBLookupComboDataLink.UpdateData;
begin
  FOwner.UpdateLinkData(self)
end;

constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
begin
  inherited Create;
  FOwner := AOwner
end;

{ TIBLookupComboEditBox }

procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
begin
  FTimer.Interval := 0;
  FFiltered := Text <> '';
  UpdateList
end;

procedure TIBLookupComboEditBox.ListDatasetChanged;
begin
  if FCurListDataset <> ListDataSet then
  begin
    if (FCurListDataset <> nil) and (FCurListDataset is IDynamicSQLDataset) then
      (FCurListDataset as IDynamicSQLDataset).UnRegisterDynamicComponent(self);
    if (ListDataSet <> nil) and (ListDataSet is IDynamicSQLDataset) then
    with ListDataSet as IDynamicSQLDataset do
    if [dcUpdateWhereClause,dcChangeDatasetOrder] <= GetCapabilities then
      RegisterDynamicComponent(self);
    FCurListDataset := ListDataSet;
  end;
end;

function TIBLookupComboEditBox.GetListSource: TDataSource;
begin
  Result := inherited ListSource;
end;

function TIBLookupComboEditBox.GetRelationNameQualifier: string;
begin
  if FRelationName <> '' then
     Result := FRelationName + '.'
  else
    Result := ''
end;

procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
begin
  if not FInserting and not FUpdating then
     Application.QueueAsyncCall(@DoActiveChanged,0);
  ListDatasetChanged;
end;

procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;

  if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
     and ListSource.DataSet.Active   then
  begin
    begin
      ValidateListField;
      if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
        KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
      else
      begin
        KeyValue := FLastKeyValue;
        UpdateData(self); {Force auto scroll}
        if varIsNull(KeyValue) then {Value not present}
          Text := ListSource.DataSet.FieldByName(ListField).AsString
      end;
    end;
  end
  else
  if (DataSource <> nil) and  assigned(DataSource.DataSet) and
                   (DataSource.DataSet.Active) and (DataField <> '') then
  begin
    ResetParser;
    KeyValue := Field.AsVariant;
  end
  else
    Text := '';
  FOriginalTextValue := Text;
end;

function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
begin
  Result := inherited AutoCompleteText;
  if AutoComplete then
     Result := Result + [cbactEnabled]
end;

function TIBLookupComboEditBox.GetListDatset : TDataset;
begin
  if ListSource = nil then
    Result := nil
  else
    Result := ListSource.Dataset;
end;

procedure TIBLookupComboEditBox.ResetParser;
var curKeyValue: variant;
begin
  if FFiltered then
  begin
    FFiltered := false;
    curKeyValue := KeyValue;
    Text := ''; {Ensure full list}
    UpdateList;
    KeyValue := curKeyValue;
    UpdateData(self); {Force Scroll}
  end;
end;

procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
begin
  {Make sure that we are in sync with other data controls}
  if DataSource = nil then
  begin
    KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
    if VarIsNull(KeyValue) then {Probable deletion}
    begin
      UpdateList;
      KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
    end;
  end;
end;

procedure TIBLookupComboEditBox.SetAutoCompleteText(
  AValue: TComboBoxAutoCompleteText);
begin
  if AValue <> AutoCompleteText then
  begin
    FAutoComplete := cbactEnabled in AValue;
    inherited AutoCompleteText := AValue - [cbactEnabled]
  end;
end;

procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
begin
  if AValue <> inherited ListSource then
  begin
    FDataLink.DataSource := AValue;
    inherited ListSource := AValue;
    ListDatasetChanged;
  end;
end;

procedure TIBLookupComboEditBox.UpdateList;
{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
  ListSource DataSet as the source for the autocomplete text. It also runs
  after a delay rather than immediately on keyup
}
var
  iSelStart: Integer; // char position
  sCompleteText, sPrefixText, sResultText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet)
     and ListSource.DataSet.Active then
  begin
    FCurText := Text;
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := FCurText;
         if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> FCurText) then
             begin
               KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
               sResultText := sCompleteText;
               if ((cbactEndOfLineComplete in AutoCompleteText) and
                         (cbactRetainPrefixCase in AutoCompleteText)) then
               begin//Retain Prefix Character cases
                 UTF8Delete(sResultText, 1, iSelStart);
                 UTF8Insert(sPrefixText, sResultText, 1);
               end;
               Text := sResultText;
             end;
             SelStart := iSelStart;
             SelLength := UTF8Length(Text) - iSelStart;
           end
           else
           begin
             SelStart := iSelStart;
             SelLength := 0;
           end;
         end;
    finally
      FUpdating := false
    end;
    FModified := true;
  end;
end;

procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;
   SelectAll
end;

procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
begin
  if FInserting then
    ListSource.DataSet.FieldByName(ListField).AsString := Text
end;

{Check to ensure that ListField exists and convert to upper case if necessary}

procedure TIBLookupComboEditBox.ValidateListField;
var  FieldNames: TStringList;
begin
  if (ListSource = nil) or (ListSource.DataSet = nil) then Exit;
  FieldNames := TStringList.Create;
  try
    FieldNames.CaseSensitive := true;
    FieldNames.Sorted := true;
    FieldNames.Duplicates := dupError;
    ListSource.DataSet.GetFieldNames(FieldNames);
    if FieldNames.IndexOf(ListField) = -1 then {not found}
    begin
      if FieldNames.IndexOf(AnsiUpperCase(ListField)) <> - 1 then {normalise to upper case}
        ListField := AnsiUpperCase(ListField)
      else
        raise Exception.CreateFmt(ibxeListFieldNotFound,[ListField])
    end;
  finally
    FieldNames.Free;
  end;
end;

procedure TIBLookupComboEditBox.CheckAndInsert;
var Accept: boolean;
    NewKeyValue: variant;
begin
  if FInCheckAndInsert then Exit;
  FInCheckAndInsert := true;
  try
       if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
          and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
       try
         {Is it OK to insert a new list member?}
         Accept := true;
         if assigned(FOnCanAutoInsert) then
            OnCanAutoInsert(self,Text,Accept);
         if not Accept then
         begin
           ResetParser;
           Text := FOriginalTextValue;
           SelectAll;
           Exit;
         end;

         FInserting := true;
         try
           {New Value}
           FFiltered := false;
           if assigned(FOnAutoInsert) then
           begin
             {In an OnAutoInsert handler, the client is expected to insert the new
              row into the List DataSet and to set the KeyValue property to the
              value of the primary key of the new row.}
             OnAutoInsert(self,Text,NewKeyValue);
           end
           else
           begin
             ListSource.DataSet.Append;
             {The new KeyValue should be determined by an external generator or
              in the "OnInsert" handler. If it is the same as the ListField, then
              it will be set from the UpdateLinkData method}
             try
               ListSource.DataSet.Post;
             except
               ListSource.DataSet.Cancel;
               raise;
             end;
             NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           end;
           Text := ''; {Ensure full list}
           UpdateList;
           KeyValue := NewKeyValue;
           UpdateData(nil); {Force sync with DataField}
         finally
           FInserting := false
         end;
       except
         Text := FOriginalTextValue;
         ResetParser;
         raise;
       end;
  finally
    FInCheckAndInsert := false
  end;
end;

procedure TIBLookupComboEditBox.DoEnter;
begin
  inherited DoEnter;
  FOriginalTextValue:= Text;
  ResetParser;
  Application.QueueAsyncCall(@HandleEnter,0);
end;

procedure TIBLookupComboEditBox.DoExit;
begin
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  FExiting := true;
  try
    CheckAndInsert;
    ResetParser;
    FTimer.Interval := 0;
  finally
    FExiting := false;
  end;
  inherited DoExit;
end;

procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);
  if Key = VK_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  if AutoComplete and (Style <> csDropDownList) then
  begin
    if (Key = VK_BACK) or (Key = VK_DELETE) then
    begin
      if SelStart = 0 then
      begin
        SelStart := UTF8Length(Text);
        SelLength := 0;
      end;
      FTimer.Interval := 0;
    end
    else
    if IsEditableTextKey(Key) and
     (not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
    begin
      FTimer.Interval := 0;
      FTimer.Interval := FKeyPressInterval;
    end;
  end;
end;

procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = DataSource) then
    ListSource := nil;
end;

procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
begin
  if Val > 0 then
    FCurText := '';
  inherited SetItemIndex(Val);
  FLastKeyValue := KeyValue;
end;

procedure TIBLookupComboEditBox.UpdateShowing;
begin
  inherited UpdateShowing;
  if Showing then {Ensure up-to-date as we were ignoring any changes}
    ActiveChanged(nil);
end;

procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
begin
  inherited UpdateData(Sender);
  if FCurText <> '' then
    Text := FCurText + Text;
  FModified := false;
end;

procedure TIBLookupComboEditBox.UpdateSQL(SQLEditor : IDynamicSQLEditor);
var FilterText: string;
begin
  if FFiltered then
  begin
    if FUpdating then
      FilterText := FCurText
    else
      FilterText := Text;

    with SQLEditor do
    begin
      if cbactSearchCaseSensitive in AutoCompleteText then
        Add2WhereClause(GetRelationNameQualifier + QuoteIdentifierIfNeeded(ListField) + ' Like ''' +
                                    SQLSafeString(FilterText) + '%''')
      else
        Add2WhereClause('Upper(' + GetRelationNameQualifier + QuoteIdentifierIfNeeded(ListField) + ') Like Upper(''' +
                                    SQLSafeString(FilterText) + '%'')');

      if cbactSearchAscending in AutoCompleteText then
        Orderby(ListField,true);
    end;
  end;
  if assigned(FOnUpdateSQL) then
    OnUpdateSQL(self,SQLEditor);
end;

procedure TIBLookupComboEditBox.SetParams(SQLParamProvider : IDynamicSQLParam);
begin
  if assigned(FOnSetParams) then
    OnSetParams(self, SQLParamProvider);
end;


{Workarounds due to bugs in various Lazarus 2.0 release candidates}
{$if lcl_fullversion >= 2000002}
type

  { THackedCustomComboBox }

  THackedCustomComboBox = class(TCustomComboBox)
  private
    procedure CallChange;
    procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
  end;

{ THackedCustomComboBox }

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
end;

procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  inherited UTF8KeyPress(UTF8Key);
end;

procedure TIBLookupComboEditBox.Change;
begin
  if DataSource = nil then
    THackedCustomComboBox(self).CallChange
  else
    inherited Change;
end;

procedure TIBLookupComboEditBox.CloseUp;
begin
  inherited DoEdit;
  inherited CloseUp;
  EditingDone;
end;

procedure TIBLookupComboEditBox.Select;
begin
  inherited Select;
  if DataSource = nil then
    inherited DoEdit;
end;

function TIBLookupComboEditBox.DoEdit: boolean;
begin
  {DoEdit will swallow characters if no editable Field. Hence, to enabled
   writing we must avoid calling the inherited method.}
  if DataSource = nil then
    Result := true
  else
    Result := inherited DoEdit;
end;
{$ifend}

{$if lcl_fullversion = 2000002}
procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  if DataSource = nil then
    THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
  else
    inherited;
end;
{$ifend}


constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
begin
  inherited Create(TheComponent);
  FDataLink := TIBLookupComboDataLink.Create(self);
  FKeyPressInterval := 200;
  FAutoComplete := true;
  FTimer := TTimer.Create(nil);
  FTimer.Interval := 0;
  FTimer.OnTimer := @HandleTimer;
  FLastKeyValue := NULL;
end;

destructor TIBLookupComboEditBox.Destroy;
begin
  if ListDataset <> nil then
    (ListDataset as IDynamicSQLDataset).UnRegisterDynamicComponent(self);
  if assigned(FDataLink) then FDataLink.Free;
  if assigned(FTimer) then FTimer.Free;
  Application.RemoveAsyncCalls(self);
  inherited Destroy;
end;

procedure TIBLookupComboEditBox.EditingDone;
begin
  FForceAutoComplete := true;
  try
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  finally
    FForceAutoComplete := false;
  end;
  CheckAndInsert;
  FCurText := '';
  if FModified then
    Change; {ensure Update}
  inherited EditingDone;
end;

end.
Revision:	435
Committed:	Mon Jun 3 13:11:42 2024 UTC (3 months, 2 weeks ago) by tony
Content type:	text/x-pascal
File size:	20932 byte(s)
Log Message:	Publication of R2-7-0
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26	unit IBLookupComboEditBox;
27
28	{$mode objfpc}{$H+}
29
30	interface
31
32	uses
33	Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	ExtCtrls, DB, StdCtrls, LCLVersion, IBDynamicInterfaces;
35
36	type
37
38	{TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
39	of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
40	to revise the available list and restrict it to items that are prefixed by the
41	typed text (either case sensitive or case insenstive). Autoinsert allows a
42	newly typed entry to be added to the list dataset and included in the available
43	list items. }
44
45	TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
46	TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;
47
48	TIBLookupComboEditBox = class;
49
50	{ TIBLookupComboDataLink }
51
52	TIBLookupComboDataLink = class(TDataLink)
53	private
54	FOwner: TIBLookupComboEditBox;
55	protected
56	procedure ActiveChanged; override;
57	{$if lcl_fullversion < 2000000}
58	procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
59	{$endif}
60	procedure RecordChanged(Field: TField); override;
61	procedure UpdateData; override;
62	public
63	constructor Create(AOwner: TIBLookupComboEditBox);
64	end;
65
66	{ TIBLookupComboEditBox }
67
68	TIBLookupComboEditBox = class(TDBLookupComboBox,IDynamicSQLComponent)
69	private
70	{ Private declarations }
71	FDataLink: TIBLookupComboDataLink;
72	FAutoComplete: boolean;
73	FAutoInsert: boolean;
74	FKeyPressInterval: integer;
75	FOnCanAutoInsert: TCanAutoInsert;
76	FOnSetParams : TOnSetParams;
77	FOnUpdateSQL : TOnUpdateSQL;
78	FRelationName: string;
79	FTimer: TTimer;
80	FFiltered: boolean;
81	FOnAutoInsert: TAutoInsert;
82	FOriginalTextValue: string;
83	FUpdating: boolean;
84	FInserting: boolean;
85	FExiting: boolean;
86	FForceAutoComplete: boolean;
87	FInCheckAndInsert: boolean;
88	FLastKeyValue: variant;
89	FCurText: string;
90	FModified: boolean;
91	FCurListDataset: TDataset;
92	procedure DoActiveChanged(Data: PtrInt);
93	function GetAutoCompleteText: TComboBoxAutoCompleteText;
94	function GetListDatset : TDataset;
95	function GetListSource: TDataSource;
96	function GetRelationNameQualifier: string;
97	procedure HandleTimer(Sender: TObject);
98	procedure ListDatasetChanged;
99	procedure ResetParser;
100	procedure RecordChanged(Sender: TObject; aField: TField);
101	procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
102	procedure SetListSource(AValue: TDataSource);
103	procedure UpdateList;
104	procedure HandleEnter(Data: PtrInt);
105	procedure UpdateLinkData(Sender: TObject);
106	procedure ValidateListField;
107	protected
108	{ Protected declarations }
109	procedure ActiveChanged(Sender: TObject);
110	procedure CheckAndInsert;
111	procedure DoEnter; override;
112	procedure DoExit; override;
113	{$if lcl_fullversion >= 2000002}
114	{Deferred update changes in Lazarus 2.0 stop the combo box working when
115	the datasource is nil. We thus have to reverse out the changes :(}
116	function DoEdit: boolean; override;
117	procedure Change; override;
118	procedure CloseUp; override;
119	procedure Select; override;
120	{$ifend}
121	{$if lcl_fullversion = 2000002}
122	procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
123	{$ifend}
124	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
125	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
126	procedure SetItemIndex(const Val: integer); override;
127	procedure UpdateShowing; override;
128	procedure UpdateData(Sender: TObject); override;
129	{IDynamicSQLComponent}
130	procedure UpdateSQL(SQLEditor: IDynamicSQLEditor);
131	procedure SetParams(SQLParamProvider: IDynamicSQLParam);
132	public
133	{ Public declarations }
134	constructor Create(TheComponent: TComponent); override;
135	destructor Destroy; override;
136	procedure EditingDone; override;
137	property ListDataSet: TDataset read GetListDatset;
138	published
139	{ Published declarations }
140	property AutoInsert: boolean read FAutoInsert write FAutoInsert;
141	property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
142	property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
143	write SetAutoCompleteText;
144	property ItemHeight;
145	property ItemWidth;
146	property ListSource: TDataSource read GetListSource write SetListSource;
147	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
148	property RelationName: string read FRelationName write FRelationName;
149	property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
150	property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
151	property OnUpdateSQL: TOnUpdateSQL read FOnUpdateSQL write FOnUpdateSQL;
152	property OnSetParams: TOnSetParams read FOnSetParams write FOnSetParams;
153	end;
154
155
156	implementation
157
158	uses Variants, LCLProc, LazUTF8;
159
160	resourcestring
161	ibxeListFieldNotFound = 'ListField Name is not a valid dataset column name (%s)';
162
163
164	{ TIBLookupComboDataLink }
165
166	procedure TIBLookupComboDataLink.ActiveChanged;
167	begin
168	FOwner.ActiveChanged(self)
169	end;
170
171	{$if lcl_fullversion < 2000000}
172	procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
173	begin
174	inherited DataEvent(Event, Info);
175	if Event = deLayoutChange then
176	FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
177	end;
178	{$endif}
179
180	procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
181	begin
182	FOwner.RecordChanged(self,Field);
183	end;
184
185	procedure TIBLookupComboDataLink.UpdateData;
186	begin
187	FOwner.UpdateLinkData(self)
188	end;
189
190	constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
191	begin
192	inherited Create;
193	FOwner := AOwner
194	end;
195
196	{ TIBLookupComboEditBox }
197
198	procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
199	begin
200	FTimer.Interval := 0;
201	FFiltered := Text <> '';
202	UpdateList
203	end;
204
205	procedure TIBLookupComboEditBox.ListDatasetChanged;
206	begin
207	if FCurListDataset <> ListDataSet then
208	begin
209	if (FCurListDataset <> nil) and (FCurListDataset is IDynamicSQLDataset) then
210	(FCurListDataset as IDynamicSQLDataset).UnRegisterDynamicComponent(self);
211	if (ListDataSet <> nil) and (ListDataSet is IDynamicSQLDataset) then
212	with ListDataSet as IDynamicSQLDataset do
213	if [dcUpdateWhereClause,dcChangeDatasetOrder] <= GetCapabilities then
214	RegisterDynamicComponent(self);
215	FCurListDataset := ListDataSet;
216	end;
217	end;
218
219	function TIBLookupComboEditBox.GetListSource: TDataSource;
220	begin
221	Result := inherited ListSource;
222	end;
223
224	function TIBLookupComboEditBox.GetRelationNameQualifier: string;
225	begin
226	if FRelationName <> '' then
227	Result := FRelationName + '.'
228	else
229	Result := ''
230	end;
231
232	procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
233	begin
234	if not FInserting and not FUpdating then
235	Application.QueueAsyncCall(@DoActiveChanged,0);
236	ListDatasetChanged;
237	end;
238
239	procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
240	begin
241	if AppDestroying in Application.Flags then Exit;
242
243	if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
244	and ListSource.DataSet.Active then
245	begin
246	begin
247	ValidateListField;
248	if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
249	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
250	else
251	begin
252	KeyValue := FLastKeyValue;
253	UpdateData(self); {Force auto scroll}
254	if varIsNull(KeyValue) then {Value not present}
255	Text := ListSource.DataSet.FieldByName(ListField).AsString
256	end;
257	end;
258	end
259	else
260	if (DataSource <> nil) and assigned(DataSource.DataSet) and
261	(DataSource.DataSet.Active) and (DataField <> '') then
262	begin
263	ResetParser;
264	KeyValue := Field.AsVariant;
265	end
266	else
267	Text := '';
268	FOriginalTextValue := Text;
269	end;
270
271	function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
272	begin
273	Result := inherited AutoCompleteText;
274	if AutoComplete then
275	Result := Result + [cbactEnabled]
276	end;
277
278	function TIBLookupComboEditBox.GetListDatset : TDataset;
279	begin
280	if ListSource = nil then
281	Result := nil
282	else
283	Result := ListSource.Dataset;
284	end;
285
286	procedure TIBLookupComboEditBox.ResetParser;
287	var curKeyValue: variant;
288	begin
289	if FFiltered then
290	begin
291	FFiltered := false;
292	curKeyValue := KeyValue;
293	Text := ''; {Ensure full list}
294	UpdateList;
295	KeyValue := curKeyValue;
296	UpdateData(self); {Force Scroll}
297	end;
298	end;
299
300	procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
301	begin
302	{Make sure that we are in sync with other data controls}
303	if DataSource = nil then
304	begin
305	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
306	if VarIsNull(KeyValue) then {Probable deletion}
307	begin
308	UpdateList;
309	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
310	end;
311	end;
312	end;
313
314	procedure TIBLookupComboEditBox.SetAutoCompleteText(
315	AValue: TComboBoxAutoCompleteText);
316	begin
317	if AValue <> AutoCompleteText then
318	begin
319	FAutoComplete := cbactEnabled in AValue;
320	inherited AutoCompleteText := AValue - [cbactEnabled]
321	end;
322	end;
323
324	procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
325	begin
326	if AValue <> inherited ListSource then
327	begin
328	FDataLink.DataSource := AValue;
329	inherited ListSource := AValue;
330	ListDatasetChanged;
331	end;
332	end;
333
334	procedure TIBLookupComboEditBox.UpdateList;
335	{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
336	ListSource DataSet as the source for the autocomplete text. It also runs
337	after a delay rather than immediately on keyup
338	}
339	var
340	iSelStart: Integer; // char position
341	sCompleteText, sPrefixText, sResultText: string;
342	begin
343	if assigned(ListSource) and assigned(ListSource.DataSet)
344	and ListSource.DataSet.Active then
345	begin
346	FCurText := Text;
347	FUpdating := true;
348	try
349	iSelStart := SelStart;//Capture original cursor position
350	if ((iSelStart < UTF8Length(Text)) and
351	(cbactEndOfLineComplete in AutoCompleteText)) then
352	Exit;
353	sPrefixText := UTF8Copy(Text, 1, iSelStart);
354	ListSource.DataSet.Active := false;
355	ListSource.DataSet.Active := true;
356	Text := FCurText;
357	if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
358	begin
359	if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
360	begin
361	sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
362	if (sCompleteText <> FCurText) then
363	begin
364	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
365	sResultText := sCompleteText;
366	if ((cbactEndOfLineComplete in AutoCompleteText) and
367	(cbactRetainPrefixCase in AutoCompleteText)) then
368	begin//Retain Prefix Character cases
369	UTF8Delete(sResultText, 1, iSelStart);
370	UTF8Insert(sPrefixText, sResultText, 1);
371	end;
372	Text := sResultText;
373	end;
374	SelStart := iSelStart;
375	SelLength := UTF8Length(Text) - iSelStart;
376	end
377	else
378	begin
379	SelStart := iSelStart;
380	SelLength := 0;
381	end;
382	end;
383	finally
384	FUpdating := false
385	end;
386	FModified := true;
387	end;
388	end;
389
390	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
391	begin
392	if AppDestroying in Application.Flags then Exit;
393	SelectAll
394	end;
395
396	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
397	begin
398	if FInserting then
399	ListSource.DataSet.FieldByName(ListField).AsString := Text
400	end;
401
402	{Check to ensure that ListField exists and convert to upper case if necessary}
403
404	procedure TIBLookupComboEditBox.ValidateListField;
405	var FieldNames: TStringList;
406	begin
407	if (ListSource = nil) or (ListSource.DataSet = nil) then Exit;
408	FieldNames := TStringList.Create;
409	try
410	FieldNames.CaseSensitive := true;
411	FieldNames.Sorted := true;
412	FieldNames.Duplicates := dupError;
413	ListSource.DataSet.GetFieldNames(FieldNames);
414	if FieldNames.IndexOf(ListField) = -1 then {not found}
415	begin
416	if FieldNames.IndexOf(AnsiUpperCase(ListField)) <> - 1 then {normalise to upper case}
417	ListField := AnsiUpperCase(ListField)
418	else
419	raise Exception.CreateFmt(ibxeListFieldNotFound,[ListField])
420	end;
421	finally
422	FieldNames.Free;
423	end;
424	end;
425
426	procedure TIBLookupComboEditBox.CheckAndInsert;
427	var Accept: boolean;
428	NewKeyValue: variant;
429	begin
430	if FInCheckAndInsert then Exit;
431	FInCheckAndInsert := true;
432	try
433	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
434	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
435	try
436	{Is it OK to insert a new list member?}
437	Accept := true;
438	if assigned(FOnCanAutoInsert) then
439	OnCanAutoInsert(self,Text,Accept);
440	if not Accept then
441	begin
442	ResetParser;
443	Text := FOriginalTextValue;
444	SelectAll;
445	Exit;
446	end;
447
448	FInserting := true;
449	try
450	{New Value}
451	FFiltered := false;
452	if assigned(FOnAutoInsert) then
453	begin
454	{In an OnAutoInsert handler, the client is expected to insert the new
455	row into the List DataSet and to set the KeyValue property to the
456	value of the primary key of the new row.}
457	OnAutoInsert(self,Text,NewKeyValue);
458	end
459	else
460	begin
461	ListSource.DataSet.Append;
462	{The new KeyValue should be determined by an external generator or
463	in the "OnInsert" handler. If it is the same as the ListField, then
464	it will be set from the UpdateLinkData method}
465	try
466	ListSource.DataSet.Post;
467	except
468	ListSource.DataSet.Cancel;
469	raise;
470	end;
471	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
472	end;
473	Text := ''; {Ensure full list}
474	UpdateList;
475	KeyValue := NewKeyValue;
476	UpdateData(nil); {Force sync with DataField}
477	finally
478	FInserting := false
479	end;
480	except
481	Text := FOriginalTextValue;
482	ResetParser;
483	raise;
484	end;
485	finally
486	FInCheckAndInsert := false
487	end;
488	end;
489
490	procedure TIBLookupComboEditBox.DoEnter;
491	begin
492	inherited DoEnter;
493	FOriginalTextValue:= Text;
494	ResetParser;
495	Application.QueueAsyncCall(@HandleEnter,0);
496	end;
497
498	procedure TIBLookupComboEditBox.DoExit;
499	begin
500	if FTimer.Interval <> 0 then
501	HandleTimer(nil);
502	FExiting := true;
503	try
504	CheckAndInsert;
505	ResetParser;
506	FTimer.Interval := 0;
507	finally
508	FExiting := false;
509	end;
510	inherited DoExit;
511	end;
512
513	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
514	begin
515	inherited KeyUp(Key, Shift);
516	if Key = VK_ESCAPE then
517	begin
518	SelStart := UTF8Length(Text); {Ensure end of line selection}
519	ResetParser;
520	Text := FOriginalTextValue;
521	SelectAll;
522	end
523	else
524	if AutoComplete and (Style <> csDropDownList) then
525	begin
526	if (Key = VK_BACK) or (Key = VK_DELETE) then
527	begin
528	if SelStart = 0 then
529	begin
530	SelStart := UTF8Length(Text);
531	SelLength := 0;
532	end;
533	FTimer.Interval := 0;
534	end
535	else
536	if IsEditableTextKey(Key) and
537	(not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
538	begin
539	FTimer.Interval := 0;
540	FTimer.Interval := FKeyPressInterval;
541	end;
542	end;
543	end;
544
545	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
546	Operation: TOperation);
547	begin
548	inherited Notification(AComponent, Operation);
549	if (Operation = opRemove) and (AComponent = DataSource) then
550	ListSource := nil;
551	end;
552
553	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
554	begin
555	if Val > 0 then
556	FCurText := '';
557	inherited SetItemIndex(Val);
558	FLastKeyValue := KeyValue;
559	end;
560
561	procedure TIBLookupComboEditBox.UpdateShowing;
562	begin
563	inherited UpdateShowing;
564	if Showing then {Ensure up-to-date as we were ignoring any changes}
565	ActiveChanged(nil);
566	end;
567
568	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
569	begin
570	inherited UpdateData(Sender);
571	if FCurText <> '' then
572	Text := FCurText + Text;
573	FModified := false;
574	end;
575
576	procedure TIBLookupComboEditBox.UpdateSQL(SQLEditor : IDynamicSQLEditor);
577	var FilterText: string;
578	begin
579	if FFiltered then
580	begin
581	if FUpdating then
582	FilterText := FCurText
583	else
584	FilterText := Text;
585
586	with SQLEditor do
587	begin
588	if cbactSearchCaseSensitive in AutoCompleteText then
589	Add2WhereClause(GetRelationNameQualifier + QuoteIdentifierIfNeeded(ListField) + ' Like ''' +
590	SQLSafeString(FilterText) + '%''')
591	else
592	Add2WhereClause('Upper(' + GetRelationNameQualifier + QuoteIdentifierIfNeeded(ListField) + ') Like Upper(''' +
593	SQLSafeString(FilterText) + '%'')');
594
595	if cbactSearchAscending in AutoCompleteText then
596	Orderby(ListField,true);
597	end;
598	end;
599	if assigned(FOnUpdateSQL) then
600	OnUpdateSQL(self,SQLEditor);
601	end;
602
603	procedure TIBLookupComboEditBox.SetParams(SQLParamProvider : IDynamicSQLParam);
604	begin
605	if assigned(FOnSetParams) then
606	OnSetParams(self, SQLParamProvider);
607	end;
608
609
610	{Workarounds due to bugs in various Lazarus 2.0 release candidates}
611	{$if lcl_fullversion >= 2000002}
612	type
613
614	{ THackedCustomComboBox }
615
616	THackedCustomComboBox = class(TCustomComboBox)
617	private
618	procedure CallChange;
619	procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
620	end;
621
622	{ THackedCustomComboBox }
623
624	procedure THackedCustomComboBox.CallChange;
625	begin
626	inherited Change;
627	end;
628
629	procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
630	begin
631	inherited UTF8KeyPress(UTF8Key);
632	end;
633
634	procedure TIBLookupComboEditBox.Change;
635	begin
636	if DataSource = nil then
637	THackedCustomComboBox(self).CallChange
638	else
639	inherited Change;
640	end;
641
642	procedure TIBLookupComboEditBox.CloseUp;
643	begin
644	inherited DoEdit;
645	inherited CloseUp;
646	EditingDone;
647	end;
648
649	procedure TIBLookupComboEditBox.Select;
650	begin
651	inherited Select;
652	if DataSource = nil then
653	inherited DoEdit;
654	end;
655
656	function TIBLookupComboEditBox.DoEdit: boolean;
657	begin
658	{DoEdit will swallow characters if no editable Field. Hence, to enabled
659	writing we must avoid calling the inherited method.}
660	if DataSource = nil then
661	Result := true
662	else
663	Result := inherited DoEdit;
664	end;
665	{$ifend}
666
667	{$if lcl_fullversion = 2000002}
668	procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
669	begin
670	if DataSource = nil then
671	THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
672	else
673	inherited;
674	end;
675	{$ifend}
676
677
678	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
679	begin
680	inherited Create(TheComponent);
681	FDataLink := TIBLookupComboDataLink.Create(self);
682	FKeyPressInterval := 200;
683	FAutoComplete := true;
684	FTimer := TTimer.Create(nil);
685	FTimer.Interval := 0;
686	FTimer.OnTimer := @HandleTimer;
687	FLastKeyValue := NULL;
688	end;
689
690	destructor TIBLookupComboEditBox.Destroy;
691	begin
692	if ListDataset <> nil then
693	(ListDataset as IDynamicSQLDataset).UnRegisterDynamicComponent(self);
694	if assigned(FDataLink) then FDataLink.Free;
695	if assigned(FTimer) then FTimer.Free;
696	Application.RemoveAsyncCalls(self);
697	inherited Destroy;
698	end;
699
700	procedure TIBLookupComboEditBox.EditingDone;
701	begin
702	FForceAutoComplete := true;
703	try
704	if FTimer.Interval <> 0 then
705	HandleTimer(nil);
706	finally
707	FForceAutoComplete := false;
708	end;
709	CheckAndInsert;
710	FCurText := '';
711	if FModified then
712	Change; {ensure Update}
713	inherited EditingDone;
714	end;
715
716	end.