journaling/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, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;

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;
    procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;

  { TIBLookupControlLink }

  TIBLookupControlLink = class(TIBControlLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure UpdateSQL(Sender: TObject); override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FIBLookupControlLink: TIBLookupControlLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    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;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    {$if lcl_fullversion >= 2000000}
    {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;
    procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
    {$ifend}
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    function SQLSafe(aText: string): string;
    procedure UpdateShowing; override;
    procedure UpdateData(Sender: TObject); override;
  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    procedure EditingDone; override;
  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;
  end;


implementation

uses Variants, LCLProc, LazUTF8;

{ TIBLookupControlLink }

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

procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
begin
  FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
end;

{ TIBLookupComboDataLink }

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

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;

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.IBControlLinkChanged;
begin
  if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
    FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
  else
    FIBLookupControlLink.IBDataSet := nil;
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);
  IBControlLinkChanged;
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
      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;

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;
    IBControlLinkChanged;
  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 is TIBCustomDataSet)
     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;
               SelStart := iSelStart;
               SelLength := UTF8Length(Text) - iSelStart;
             end;
           end
           else
           begin
             SelStart := iSelStart;
             SelLength := 0;
           end;
         end;
    finally
      FUpdating := false
    end;
    FModified := true;
  end;
end;

procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
  Parser: TSelectSQLParser);
var FieldPosition: integer;
    FilterText: string;
begin
  if FFiltered then
  begin
    if FUpdating then
      FilterText := FCurText
    else
      FilterText := Text;
    if cbactSearchCaseSensitive in AutoCompleteText then
      Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
                                  SQLSafe(FilterText) + '%''')
    else
      Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' +  ListField + '") Like Upper(''' +
                                  SQLSafe(FilterText) + '%'')');

    if cbactSearchAscending in AutoCompleteText then
    begin
      FieldPosition := Parser.GetFieldPosition(ListField);
      if FieldPosition = 0 then Exit;

      Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
    end;
  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;

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.Loaded;
begin
  inherited Loaded;
  IBControlLinkChanged;
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;

function TIBLookupComboEditBox.SQLSafe(aText: string): string;
var I: integer;
begin
  Result := '';
  for I := 1 to length(aText) do
    if aText[I] = '''' then
      Result := Result + ''''''
    else
      Result := Result + aText[I];
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;

{$if lcl_fullversion >= 2000000}
type

  { THackedCustomComboBox }

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

{ THackedCustomComboBox }

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

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
end;

procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  {TDBLookupComboBox.UTF8KeyPress will swallow the character if
  the datalink is not editable. hence to enable writing we must override it}
  if ((DataSource = nil) or (Field = nil)) and not ReadOnly then
    THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
  else
    inherited;
end;

procedure TIBLookupComboEditBox.Change;
begin
  THackedCustomComboBox(self).CallChange;
end;

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

procedure TIBLookupComboEditBox.Select;
begin
  inherited Select;
  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) or (Field = nil)) and not ReadOnly then
    Result := true
  else
    Result := inherited DoEdit;
end;
{$ifend}

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

destructor TIBLookupComboEditBox.Destroy;
begin
  if assigned(FDataLink) then FDataLink.Free;
  if assigned(FIBLookupControlLink) then FIBLookupControlLink.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:	263
Committed:	Thu Dec 6 15:55:01 2018 UTC (6 years ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/ibcontrols/IBLookupComboEditBox.pas*
File size:	19984 byte(s)
Log Message:	Release 2.3.2 committed
#	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, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
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	procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
58	procedure RecordChanged(Field: TField); override;
59	procedure UpdateData; override;
60	public
61	constructor Create(AOwner: TIBLookupComboEditBox);
62	end;
63
64	{ TIBLookupControlLink }
65
66	TIBLookupControlLink = class(TIBControlLink)
67	private
68	FOwner: TIBLookupComboEditBox;
69	protected
70	procedure UpdateSQL(Sender: TObject); override;
71	public
72	constructor Create(AOwner: TIBLookupComboEditBox);
73	end;
74
75
76	{ TIBLookupComboEditBox }
77
78	TIBLookupComboEditBox = class(TDBLookupComboBox)
79	private
80	{ Private declarations }
81	FDataLink: TIBLookupComboDataLink;
82	FIBLookupControlLink: TIBLookupControlLink;
83	FAutoComplete: boolean;
84	FAutoInsert: boolean;
85	FKeyPressInterval: integer;
86	FOnCanAutoInsert: TCanAutoInsert;
87	FRelationName: string;
88	FTimer: TTimer;
89	FFiltered: boolean;
90	FOnAutoInsert: TAutoInsert;
91	FOriginalTextValue: string;
92	FUpdating: boolean;
93	FInserting: boolean;
94	FExiting: boolean;
95	FForceAutoComplete: boolean;
96	FInCheckAndInsert: boolean;
97	FLastKeyValue: variant;
98	FCurText: string;
99	FModified: boolean;
100	procedure DoActiveChanged(Data: PtrInt);
101	function GetAutoCompleteText: TComboBoxAutoCompleteText;
102	function GetListSource: TDataSource;
103	function GetRelationNameQualifier: string;
104	procedure HandleTimer(Sender: TObject);
105	procedure IBControlLinkChanged;
106	procedure ResetParser;
107	procedure RecordChanged(Sender: TObject; aField: TField);
108	procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
109	procedure SetListSource(AValue: TDataSource);
110	procedure UpdateList;
111	procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
112	procedure HandleEnter(Data: PtrInt);
113	procedure UpdateLinkData(Sender: TObject);
114	protected
115	{ Protected declarations }
116	procedure ActiveChanged(Sender: TObject);
117	procedure CheckAndInsert;
118	procedure DoEnter; override;
119	procedure DoExit; override;
120	{$if lcl_fullversion >= 2000000}
121	{Deferred update changes in Lazarus 2.0 stop the combo box working when
122	the datasource is nil. We thus have to reverse out the changes :(}
123	function DoEdit: boolean; override;
124	procedure Change; override;
125	procedure CloseUp; override;
126	procedure Select; override;
127	procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
128	{$ifend}
129	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
130	procedure Loaded; override;
131	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
132	procedure SetItemIndex(const Val: integer); override;
133	function SQLSafe(aText: string): string;
134	procedure UpdateShowing; override;
135	procedure UpdateData(Sender: TObject); override;
136	public
137	{ Public declarations }
138	constructor Create(TheComponent: TComponent); override;
139	destructor Destroy; override;
140	procedure EditingDone; override;
141	published
142	{ Published declarations }
143	property AutoInsert: boolean read FAutoInsert write FAutoInsert;
144	property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
145	property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
146	write SetAutoCompleteText;
147	property ItemHeight;
148	property ItemWidth;
149	property ListSource: TDataSource read GetListSource write SetListSource;
150	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
151	property RelationName: string read FRelationName write FRelationName;
152	property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
153	property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
154	end;
155
156
157	implementation
158
159	uses Variants, LCLProc, LazUTF8;
160
161	{ TIBLookupControlLink }
162
163	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
164	begin
165	inherited Create;
166	FOwner := AOwner;
167	end;
168
169	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
170	begin
171	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
172	end;
173
174	{ TIBLookupComboDataLink }
175
176	procedure TIBLookupComboDataLink.ActiveChanged;
177	begin
178	FOwner.ActiveChanged(self)
179	end;
180
181	procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
182	begin
183	inherited DataEvent(Event, Info);
184	if Event = deLayoutChange then
185	FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
186	end;
187
188	procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
189	begin
190	FOwner.RecordChanged(self,Field);
191	end;
192
193	procedure TIBLookupComboDataLink.UpdateData;
194	begin
195	FOwner.UpdateLinkData(self)
196	end;
197
198	constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
199	begin
200	inherited Create;
201	FOwner := AOwner
202	end;
203
204	{ TIBLookupComboEditBox }
205
206	procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
207	begin
208	FTimer.Interval := 0;
209	FFiltered := Text <> '';
210	UpdateList
211	end;
212
213	procedure TIBLookupComboEditBox.IBControlLinkChanged;
214	begin
215	if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
216	FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
217	else
218	FIBLookupControlLink.IBDataSet := nil;
219	end;
220
221	function TIBLookupComboEditBox.GetListSource: TDataSource;
222	begin
223	Result := inherited ListSource;
224	end;
225
226	function TIBLookupComboEditBox.GetRelationNameQualifier: string;
227	begin
228	if FRelationName <> '' then
229	Result := FRelationName + '.'
230	else
231	Result := ''
232	end;
233
234	procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
235	begin
236	if not FInserting and not FUpdating then
237	Application.QueueAsyncCall(@DoActiveChanged,0);
238	IBControlLinkChanged;
239	end;
240
241	procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
242	begin
243	if AppDestroying in Application.Flags then Exit;
244
245	if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
246	and ListSource.DataSet.Active then
247	begin
248	begin
249	if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
250	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
251	else
252	begin
253	KeyValue := FLastKeyValue;
254	UpdateData(self); {Force auto scroll}
255	if varIsNull(KeyValue) then {Value not present}
256	Text := ListSource.DataSet.FieldByName(ListField).AsString
257	end;
258	end;
259	end
260	else
261	if (DataSource <> nil) and assigned(DataSource.DataSet) and
262	(DataSource.DataSet.Active) and (DataField <> '') then
263	begin
264	ResetParser;
265	KeyValue := Field.AsVariant;
266	end
267	else
268	Text := '';
269	FOriginalTextValue := Text;
270	end;
271
272	function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
273	begin
274	Result := inherited AutoCompleteText;
275	if AutoComplete then
276	Result := Result + [cbactEnabled]
277	end;
278
279	procedure TIBLookupComboEditBox.ResetParser;
280	var curKeyValue: variant;
281	begin
282	if FFiltered then
283	begin
284	FFiltered := false;
285	curKeyValue := KeyValue;
286	Text := ''; {Ensure full list}
287	UpdateList;
288	KeyValue := curKeyValue;
289	UpdateData(self); {Force Scroll}
290	end;
291	end;
292
293	procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
294	begin
295	{Make sure that we are in sync with other data controls}
296	if DataSource = nil then
297	begin
298	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
299	if VarIsNull(KeyValue) then {Probable deletion}
300	begin
301	UpdateList;
302	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
303	end;
304	end;
305	end;
306
307	procedure TIBLookupComboEditBox.SetAutoCompleteText(
308	AValue: TComboBoxAutoCompleteText);
309	begin
310	if AValue <> AutoCompleteText then
311	begin
312	FAutoComplete := cbactEnabled in AValue;
313	inherited AutoCompleteText := AValue - [cbactEnabled]
314	end;
315	end;
316
317	procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
318	begin
319	if AValue <> inherited ListSource then
320	begin
321	FDataLink.DataSource := AValue;
322	inherited ListSource := AValue;
323	IBControlLinkChanged;
324	end;
325	end;
326
327	procedure TIBLookupComboEditBox.UpdateList;
328	{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
329	ListSource DataSet as the source for the autocomplete text. It also runs
330	after a delay rather than immediately on keyup
331	}
332	var
333	iSelStart: Integer; // char position
334	sCompleteText, sPrefixText, sResultText: string;
335	begin
336	if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
337	and ListSource.DataSet.Active then
338	begin
339	FCurText := Text;
340	FUpdating := true;
341	try
342	iSelStart := SelStart;//Capture original cursor position
343	if ((iSelStart < UTF8Length(Text)) and
344	(cbactEndOfLineComplete in AutoCompleteText)) then
345	Exit;
346	sPrefixText := UTF8Copy(Text, 1, iSelStart);
347	ListSource.DataSet.Active := false;
348	ListSource.DataSet.Active := true;
349	Text := FCurText;
350	if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
351	begin
352	if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
353	begin
354	sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
355	if (sCompleteText <> FCurText) then
356	begin
357	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
358	sResultText := sCompleteText;
359	if ((cbactEndOfLineComplete in AutoCompleteText) and
360	(cbactRetainPrefixCase in AutoCompleteText)) then
361	begin//Retain Prefix Character cases
362	UTF8Delete(sResultText, 1, iSelStart);
363	UTF8Insert(sPrefixText, sResultText, 1);
364	end;
365	Text := sResultText;
366	SelStart := iSelStart;
367	SelLength := UTF8Length(Text) - iSelStart;
368	end;
369	end
370	else
371	begin
372	SelStart := iSelStart;
373	SelLength := 0;
374	end;
375	end;
376	finally
377	FUpdating := false
378	end;
379	FModified := true;
380	end;
381	end;
382
383	procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
384	Parser: TSelectSQLParser);
385	var FieldPosition: integer;
386	FilterText: string;
387	begin
388	if FFiltered then
389	begin
390	if FUpdating then
391	FilterText := FCurText
392	else
393	FilterText := Text;
394	if cbactSearchCaseSensitive in AutoCompleteText then
395	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
396	SQLSafe(FilterText) + '%''')
397	else
398	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
399	SQLSafe(FilterText) + '%'')');
400
401	if cbactSearchAscending in AutoCompleteText then
402	begin
403	FieldPosition := Parser.GetFieldPosition(ListField);
404	if FieldPosition = 0 then Exit;
405
406	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
407	end;
408	end;
409	end;
410
411	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
412	begin
413	if AppDestroying in Application.Flags then Exit;
414	SelectAll
415	end;
416
417	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
418	begin
419	if FInserting then
420	ListSource.DataSet.FieldByName(ListField).AsString := Text
421	end;
422
423	procedure TIBLookupComboEditBox.CheckAndInsert;
424	var Accept: boolean;
425	NewKeyValue: variant;
426	begin
427	if FInCheckAndInsert then Exit;
428	FInCheckAndInsert := true;
429	try
430	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
431	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
432	try
433	{Is it OK to insert a new list member?}
434	Accept := true;
435	if assigned(FOnCanAutoInsert) then
436	OnCanAutoInsert(self,Text,Accept);
437	if not Accept then
438	begin
439	ResetParser;
440	Text := FOriginalTextValue;
441	SelectAll;
442	Exit;
443	end;
444
445	FInserting := true;
446	try
447	{New Value}
448	FFiltered := false;
449	if assigned(FOnAutoInsert) then
450	begin
451	{In an OnAutoInsert handler, the client is expected to insert the new
452	row into the List DataSet and to set the KeyValue property to the
453	value of the primary key of the new row.}
454	OnAutoInsert(self,Text,NewKeyValue);
455	end
456	else
457	begin
458	ListSource.DataSet.Append;
459	{The new KeyValue should be determined by an external generator or
460	in the "OnInsert" handler. If it is the same as the ListField, then
461	it will be set from the UpdateLinkData method}
462	try
463	ListSource.DataSet.Post;
464	except
465	ListSource.DataSet.Cancel;
466	raise;
467	end;
468	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
469	end;
470	Text := ''; {Ensure full list}
471	UpdateList;
472	KeyValue := NewKeyValue;
473	UpdateData(nil); {Force sync with DataField}
474	finally
475	FInserting := false
476	end;
477	except
478	Text := FOriginalTextValue;
479	ResetParser;
480	raise;
481	end;
482	finally
483	FInCheckAndInsert := false
484	end;
485	end;
486
487	procedure TIBLookupComboEditBox.DoEnter;
488	begin
489	inherited DoEnter;
490	FOriginalTextValue:= Text;
491	ResetParser;
492	Application.QueueAsyncCall(@HandleEnter,0);
493	end;
494
495	procedure TIBLookupComboEditBox.DoExit;
496	begin
497	if FTimer.Interval <> 0 then
498	HandleTimer(nil);
499	FExiting := true;
500	try
501	CheckAndInsert;
502	ResetParser;
503	FTimer.Interval := 0;
504	finally
505	FExiting := false;
506	end;
507	inherited DoExit;
508	end;
509
510	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
511	begin
512	inherited KeyUp(Key, Shift);
513	if Key = VK_ESCAPE then
514	begin
515	SelStart := UTF8Length(Text); {Ensure end of line selection}
516	ResetParser;
517	Text := FOriginalTextValue;
518	SelectAll;
519	end
520	else
521	if AutoComplete and (Style <> csDropDownList) then
522	begin
523	if (Key = VK_BACK) or (Key = VK_DELETE) then
524	begin
525	if SelStart = 0 then
526	begin
527	SelStart := UTF8Length(Text);
528	SelLength := 0;
529	end;
530	FTimer.Interval := 0;
531	end
532	else
533	if IsEditableTextKey(Key) and
534	(not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
535	begin
536	FTimer.Interval := 0;
537	FTimer.Interval := FKeyPressInterval;
538	end;
539	end;
540	end;
541
542	procedure TIBLookupComboEditBox.Loaded;
543	begin
544	inherited Loaded;
545	IBControlLinkChanged;
546	end;
547
548	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
549	Operation: TOperation);
550	begin
551	inherited Notification(AComponent, Operation);
552	if (Operation = opRemove) and (AComponent = DataSource) then
553	ListSource := nil;
554	end;
555
556	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
557	begin
558	if Val > 0 then
559	FCurText := '';
560	inherited SetItemIndex(Val);
561	FLastKeyValue := KeyValue;
562	end;
563
564	function TIBLookupComboEditBox.SQLSafe(aText: string): string;
565	var I: integer;
566	begin
567	Result := '';
568	for I := 1 to length(aText) do
569	if aText[I] = '''' then
570	Result := Result + ''''''
571	else
572	Result := Result + aText[I];
573	end;
574
575	procedure TIBLookupComboEditBox.UpdateShowing;
576	begin
577	inherited UpdateShowing;
578	if Showing then {Ensure up-to-date as we were ignoring any changes}
579	ActiveChanged(nil);
580	end;
581
582	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
583	begin
584	inherited UpdateData(Sender);
585	if FCurText <> '' then
586	Text := FCurText + Text;
587	FModified := false;
588	end;
589
590	{$if lcl_fullversion >= 2000000}
591	type
592
593	{ THackedCustomComboBox }
594
595	THackedCustomComboBox = class(TCustomComboBox)
596	private
597	procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
598	procedure CallChange;
599	end;
600
601	{ THackedCustomComboBox }
602
603	procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
604	begin
605	inherited UTF8KeyPress(UTF8Key);
606	end;
607
608	procedure THackedCustomComboBox.CallChange;
609	begin
610	inherited Change;
611	end;
612
613	procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
614	begin
615	{TDBLookupComboBox.UTF8KeyPress will swallow the character if
616	the datalink is not editable. hence to enable writing we must override it}
617	if ((DataSource = nil) or (Field = nil)) and not ReadOnly then
618	THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
619	else
620	inherited;
621	end;
622
623	procedure TIBLookupComboEditBox.Change;
624	begin
625	THackedCustomComboBox(self).CallChange;
626	end;
627
628	procedure TIBLookupComboEditBox.CloseUp;
629	begin
630	inherited CloseUp;
631	inherited DoEdit;
632	end;
633
634	procedure TIBLookupComboEditBox.Select;
635	begin
636	inherited Select;
637	inherited DoEdit;
638	end;
639
640	function TIBLookupComboEditBox.DoEdit: boolean;
641	begin
642	{DoEdit will swallow characters if no editable Field. Hence, to enabled
643	writing we must avoid calling the inherited method.}
644	if ((DataSource = nil) or (Field = nil)) and not ReadOnly then
645	Result := true
646	else
647	Result := inherited DoEdit;
648	end;
649	{$ifend}
650
651	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
652	begin
653	inherited Create(TheComponent);
654	FDataLink := TIBLookupComboDataLink.Create(self);
655	FIBLookupControlLink := TIBLookupControlLink.Create(self);
656	FKeyPressInterval := 200;
657	FAutoComplete := true;
658	FTimer := TTimer.Create(nil);
659	FTimer.Interval := 0;
660	FTimer.OnTimer := @HandleTimer;
661	FLastKeyValue := NULL;
662	end;
663
664	destructor TIBLookupComboEditBox.Destroy;
665	begin
666	if assigned(FDataLink) then FDataLink.Free;
667	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
668	if assigned(FTimer) then FTimer.Free;
669	Application.RemoveAsyncCalls(self);
670	inherited Destroy;
671	end;
672
673	procedure TIBLookupComboEditBox.EditingDone;
674	begin
675	FForceAutoComplete := true;
676	try
677	if FTimer.Interval <> 0 then
678	HandleTimer(nil);
679	finally
680	FForceAutoComplete := false;
681	end;
682	CheckAndInsert;
683	FCurText := '';
684	if FModified then
685	Change; {ensure Update}
686	inherited EditingDone;
687	end;
688
689	end.