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

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 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
    FCanAutoInsert: TCanAutoInsert;
    { 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;
    FLastKeyValue: variant;
    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;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    function SQLSafe(aText: string): string;
    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 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 IBQuery, LCLType, Variants, LCLProc;

{ 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.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;

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;
  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 ''' +
                                  SQLSafe(Text) + '%''')
    else
      Parser.Add2WhereClause(GetRelationNameQualifier + 'Upper("' + ListField + '") Like Upper(''' +
                                  SQLSafe(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.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
  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;

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;
  inherited Destroy;
end;

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

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