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, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
  ExtCtrls, IBSQLParser, DB, StdCtrls;

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;


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    FCanAutoInsert: TCanAutoInsert;
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FLastKeyValue: variant;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    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;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure SetItemIndex(const Val: integer); override;
    procedure UpdateShowing; 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 500;
    property RelationName: string read FRelationName write FRelationName;
    property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
    property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
  end;


implementation

uses IBQuery, IBCustomDataSet, LCLType, Variants, LCLProc;

{ TIBLookupComboDataLink }

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

procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
begin
  {If we are not visible then avoid unnecessary work}
  if not FOwner.Showing then Exit;

  if (Event = deCheckBrowseMode) and (Info = 1) and not DataSet.Active then
  begin
    if (DataSet is TIBDataSet) then
      FOwner.UpdateSQL(self,TIBDataSet(DataSet).Parser)
    else
    if (DataSet is TIBQuery) then
      FOwner.UpdateSQL(self,TIBQuery(DataSet).Parser)
  end
  else
    inherited DataEvent(Event, Info);
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);
var ActiveState: boolean;
begin
  FTimer.Interval := 0;
  FFiltered := Text <> '';
  UpdateList
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);
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;
begin
  if FFiltered then
  begin
    FFiltered := false;
    UpdateList;
    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;
  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;
  curText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         curText := Text;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := curText;
         if not FExiting and Focused and (Text <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> Text) then
             begin
               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);
             end;
           end;
         end;
    finally
      FUpdating := false
    end;
  end;
end;

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

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

    Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
  end;
end;

procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
begin
  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 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;
end;

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

procedure TIBLookupComboEditBox.DoExit;
begin
  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_RETURN then
     EditingDone
  else
  if Key = VK_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  if (IsEditableTextKey(Key) or (Key = VK_BACK))
     and AutoComplete and (Style <> csDropDownList) and
     (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
    FTimer.Interval := FKeyPressInterval
  else
    FTimer.Interval := 0
end;

procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
begin
  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;

constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
begin
  inherited Create(TheComponent);
  FDataLink := TIBLookupComboDataLink.Create(self);
  FKeyPressInterval := 500;
  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(FTimer) then FTimer.Free;
  inherited Destroy;
end;

procedure TIBLookupComboEditBox.EditingDone;
begin
  CheckAndInsert;
  inherited EditingDone;
end;

end.
Revision:	23
Committed:	Fri Mar 13 10:26:52 2015 UTC (9 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	14785 byte(s)
Log Message:	Committing updates for Release R1-2-1
#	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, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	ExtCtrls, IBSQLParser, DB, StdCtrls;
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
65	{ TIBLookupComboEditBox }
66
67	TIBLookupComboEditBox = class(TDBLookupComboBox)
68	private
69	FCanAutoInsert: TCanAutoInsert;
70	{ Private declarations }
71	FDataLink: TIBLookupComboDataLink;
72	FAutoComplete: boolean;
73	FAutoInsert: boolean;
74	FKeyPressInterval: integer;
75	FOnCanAutoInsert: TCanAutoInsert;
76	FRelationName: string;
77	FTimer: TTimer;
78	FFiltered: boolean;
79	FOnAutoInsert: TAutoInsert;
80	FOriginalTextValue: string;
81	FUpdating: boolean;
82	FInserting: boolean;
83	FExiting: boolean;
84	FLastKeyValue: variant;
85	procedure DoActiveChanged(Data: PtrInt);
86	function GetAutoCompleteText: TComboBoxAutoCompleteText;
87	function GetListSource: TDataSource;
88	function GetRelationNameQualifier: string;
89	procedure HandleTimer(Sender: TObject);
90	procedure ResetParser;
91	procedure RecordChanged(Sender: TObject; aField: TField);
92	procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
93	procedure SetListSource(AValue: TDataSource);
94	procedure UpdateList;
95	procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
96	procedure HandleEnter(Data: PtrInt);
97	procedure UpdateLinkData(Sender: TObject);
98	protected
99	{ Protected declarations }
100	procedure ActiveChanged(Sender: TObject);
101	procedure CheckAndInsert;
102	procedure DoEnter; override;
103	procedure DoExit; override;
104	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
105	procedure SetItemIndex(const Val: integer); override;
106	procedure UpdateShowing; override;
107	public
108	{ Public declarations }
109	constructor Create(TheComponent: TComponent); override;
110	destructor Destroy; override;
111	procedure EditingDone; override;
112	published
113	{ Published declarations }
114	property AutoInsert: boolean read FAutoInsert write FAutoInsert;
115	property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
116	property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
117	write SetAutoCompleteText;
118	property ItemHeight;
119	property ItemWidth;
120	property ListSource: TDataSource read GetListSource write SetListSource;
121	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 500;
122	property RelationName: string read FRelationName write FRelationName;
123	property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
124	property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
125	end;
126
127
128	implementation
129
130	uses IBQuery, IBCustomDataSet, LCLType, Variants, LCLProc;
131
132	{ TIBLookupComboDataLink }
133
134	procedure TIBLookupComboDataLink.ActiveChanged;
135	begin
136	FOwner.ActiveChanged(self)
137	end;
138
139	procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
140	begin
141	{If we are not visible then avoid unnecessary work}
142	if not FOwner.Showing then Exit;
143
144	if (Event = deCheckBrowseMode) and (Info = 1) and not DataSet.Active then
145	begin
146	if (DataSet is TIBDataSet) then
147	FOwner.UpdateSQL(self,TIBDataSet(DataSet).Parser)
148	else
149	if (DataSet is TIBQuery) then
150	FOwner.UpdateSQL(self,TIBQuery(DataSet).Parser)
151	end
152	else
153	inherited DataEvent(Event, Info);
154	end;
155
156	procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
157	begin
158	FOwner.RecordChanged(self,Field);
159	end;
160
161	procedure TIBLookupComboDataLink.UpdateData;
162	begin
163	FOwner.UpdateLinkData(self)
164	end;
165
166	constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
167	begin
168	inherited Create;
169	FOwner := AOwner
170	end;
171
172	{ TIBLookupComboEditBox }
173
174	procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
175	var ActiveState: boolean;
176	begin
177	FTimer.Interval := 0;
178	FFiltered := Text <> '';
179	UpdateList
180	end;
181
182	function TIBLookupComboEditBox.GetListSource: TDataSource;
183	begin
184	Result := inherited ListSource;
185	end;
186
187	function TIBLookupComboEditBox.GetRelationNameQualifier: string;
188	begin
189	if FRelationName <> '' then
190	Result := FRelationName + '.'
191	else
192	Result := ''
193	end;
194
195	procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
196	begin
197	if not FInserting and not FUpdating then
198	Application.QueueAsyncCall(@DoActiveChanged,0);
199	end;
200
201	procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
202	begin
203	if AppDestroying in Application.Flags then Exit;
204
205	if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
206	and ListSource.DataSet.Active then
207	begin
208	begin
209	if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
210	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
211	else
212	begin
213	KeyValue := FLastKeyValue;
214	UpdateData(self); {Force auto scroll}
215	if varIsNull(KeyValue) then {Value not present}
216	Text := ListSource.DataSet.FieldByName(ListField).AsString
217	end;
218	end;
219	end
220	else
221	if (DataSource <> nil) and assigned(DataSource.DataSet) and
222	(DataSource.DataSet.Active) and (DataField <> '') then
223	begin
224	ResetParser;
225	KeyValue := Field.AsVariant;
226	end
227	else
228	Text := '';
229	FOriginalTextValue := Text;
230	end;
231
232	function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
233	begin
234	Result := inherited AutoCompleteText;
235	if AutoComplete then
236	Result := Result + [cbactEnabled]
237	end;
238
239	procedure TIBLookupComboEditBox.ResetParser;
240	begin
241	if FFiltered then
242	begin
243	FFiltered := false;
244	UpdateList;
245	UpdateData(self); {Force Scroll}
246	end;
247	end;
248
249	procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
250	begin
251	{Make sure that we are in sync with other data controls}
252	if DataSource = nil then
253	begin
254	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
255	if VarIsNull(KeyValue) then {Probable deletion}
256	begin
257	UpdateList;
258	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
259	end;
260	end;
261	end;
262
263	procedure TIBLookupComboEditBox.SetAutoCompleteText(
264	AValue: TComboBoxAutoCompleteText);
265	begin
266	if AValue <> AutoCompleteText then
267	begin
268	FAutoComplete := cbactEnabled in AValue;
269	inherited AutoCompleteText := AValue - [cbactEnabled]
270	end;
271	end;
272
273	procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
274	begin
275	if AValue <> inherited ListSource then
276	begin
277	FDataLink.DataSource := AValue;
278	inherited ListSource := AValue;
279	end;
280	end;
281
282	procedure TIBLookupComboEditBox.UpdateList;
283	{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
284	ListSource DataSet as the source for the autocomplete text. It also runs
285	after a delay rather than immediately on keyup
286	}
287	var
288	iSelStart: Integer; // char position
289	sCompleteText, sPrefixText, sResultText: string;
290	curText: string;
291	begin
292	if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
293	and ListSource.DataSet.Active then
294	begin
295	FUpdating := true;
296	try
297	iSelStart := SelStart;//Capture original cursor position
298	if ((iSelStart < UTF8Length(Text)) and
299	(cbactEndOfLineComplete in AutoCompleteText)) then
300	Exit;
301	curText := Text;
302	sPrefixText := UTF8Copy(Text, 1, iSelStart);
303	ListSource.DataSet.Active := false;
304	ListSource.DataSet.Active := true;
305	Text := curText;
306	if not FExiting and Focused and (Text <> '')then
307	begin
308	if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
309	begin
310	sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
311	if (sCompleteText <> Text) then
312	begin
313	sResultText := sCompleteText;
314	if ((cbactEndOfLineComplete in AutoCompleteText) and
315	(cbactRetainPrefixCase in AutoCompleteText)) then
316	begin//Retain Prefix Character cases
317	UTF8Delete(sResultText, 1, iSelStart);
318	UTF8Insert(sPrefixText, sResultText, 1);
319	end;
320	Text := sResultText;
321	SelStart := iSelStart;
322	SelLength := UTF8Length(Text);
323	end;
324	end;
325	end;
326	finally
327	FUpdating := false
328	end;
329	end;
330	end;
331
332	procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
333	Parser: TSelectSQLParser);
334	var FieldPosition: integer;
335	begin
336	if FFiltered then
337	begin
338	if cbactSearchCaseSensitive in AutoCompleteText then
339	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' + Text + '%''')
340	else
341	Parser.Add2WhereClause(GetRelationNameQualifier + 'Upper("' + ListField + '") Like Upper(''' + Text + '%'')');
342
343	end;
344	if cbactSearchAscending in AutoCompleteText then
345	begin
346	FieldPosition := Parser.GetFieldPosition(ListField);
347	if FieldPosition = 0 then Exit;
348
349	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
350	end;
351	end;
352
353	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
354	begin
355	SelectAll
356	end;
357
358	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
359	begin
360	if FInserting then
361	ListSource.DataSet.FieldByName(ListField).AsString := Text
362	end;
363
364	procedure TIBLookupComboEditBox.CheckAndInsert;
365	var Accept: boolean;
366	NewKeyValue: variant;
367	begin
368	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
369	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
370	try
371	{Is it OK to insert a new list member?}
372	Accept := true;
373	if assigned(FOnCanAutoInsert) then
374	OnCanAutoInsert(self,Text,Accept);
375	if not Accept then
376	begin
377	ResetParser;
378	Text := FOriginalTextValue;
379	SelectAll;
380	Exit;
381	end;
382
383	FInserting := true;
384	try
385	{New Value}
386	FFiltered := false;
387	if assigned(FOnAutoInsert) then
388	begin
389	{In an OnAutoInsert handler, the client is expected to insert the new
390	row into the List DataSet and to set the KeyValue property to the
391	value of the primary key of the new row.}
392	OnAutoInsert(self,Text,NewKeyValue);
393	end
394	else
395	begin
396	ListSource.DataSet.Append;
397	{The new KeyValue should be determined by an external generator or
398	in the "OnInsert" handler. If it is the same as the ListField, then
399	it will be set from the UpdateLinkData method}
400	try
401	ListSource.DataSet.Post;
402	except
403	ListSource.DataSet.Cancel;
404	raise;
405	end;
406	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
407	end;
408	Text := ''; {Ensure full list}
409	UpdateList;
410	KeyValue := NewKeyValue;
411	UpdateData(nil); {Force sync with DataField}
412	finally
413	FInserting := false
414	end;
415	except
416	Text := FOriginalTextValue;
417	ResetParser;
418	raise;
419	end;
420	end;
421
422	procedure TIBLookupComboEditBox.DoEnter;
423	begin
424	inherited DoEnter;
425	FOriginalTextValue:= Text;
426	ResetParser;
427	Application.QueueAsyncCall(@HandleEnter,0);
428	end;
429
430	procedure TIBLookupComboEditBox.DoExit;
431	begin
432	FExiting := true;
433	try
434	CheckAndInsert;
435	ResetParser;
436	FTimer.Interval := 0;
437	finally
438	FExiting := false;
439	end;
440	inherited DoExit;
441	end;
442
443	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
444	begin
445	inherited KeyUp(Key, Shift);
446	if Key = VK_RETURN then
447	EditingDone
448	else
449	if Key = VK_ESCAPE then
450	begin
451	SelStart := UTF8Length(Text); {Ensure end of line selection}
452	ResetParser;
453	Text := FOriginalTextValue;
454	SelectAll;
455	end
456	else
457	if (IsEditableTextKey(Key) or (Key = VK_BACK))
458	and AutoComplete and (Style <> csDropDownList) and
459	(not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
460	FTimer.Interval := FKeyPressInterval
461	else
462	FTimer.Interval := 0
463	end;
464
465	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
466	begin
467	inherited SetItemIndex(Val);
468	FLastKeyValue := KeyValue;
469	end;
470
471	procedure TIBLookupComboEditBox.UpdateShowing;
472	begin
473	inherited UpdateShowing;
474	if Showing then {Ensure up-to-date as we were ignoring any changes}
475	ActiveChanged(nil);
476	end;
477
478	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
479	begin
480	inherited Create(TheComponent);
481	FDataLink := TIBLookupComboDataLink.Create(self);
482	FKeyPressInterval := 500;
483	FAutoComplete := true;
484	FTimer := TTimer.Create(nil);
485	FTimer.Interval := 0;
486	FTimer.OnTimer := @HandleTimer;
487	FLastKeyValue := NULL;
488	end;
489
490	destructor TIBLookupComboEditBox.Destroy;
491	begin
492	if assigned(FDataLink) then FDataLink.Free;
493	if assigned(FTimer) then FTimer.Free;
494	inherited Destroy;
495	end;
496
497	procedure TIBLookupComboEditBox.EditingDone;
498	begin
499	CheckAndInsert;
500	inherited EditingDone;
501	end;
502
503	end.