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) 2011 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;
      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:	21
Committed:	Thu Feb 26 10:33:34 2015 UTC (9 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	14748 byte(s)
Log Message:	Committing updates for Release R1-2-0
#	User	Rev	Content
1	tony	21	(*
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) 2011 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			UpdateList;
409			KeyValue := NewKeyValue;
410			UpdateData(nil); {Force sync with DataField}
411			finally
412			FInserting := false
413			end;
414			except
415			Text := FOriginalTextValue;
416			ResetParser;
417			raise;
418			end;
419			end;
420
421			procedure TIBLookupComboEditBox.DoEnter;
422			begin
423			inherited DoEnter;
424			FOriginalTextValue:= Text;
425			ResetParser;
426			Application.QueueAsyncCall(@HandleEnter,0);
427			end;
428
429			procedure TIBLookupComboEditBox.DoExit;
430			begin
431			FExiting := true;
432			try
433			CheckAndInsert;
434			ResetParser;
435			FTimer.Interval := 0;
436			finally
437			FExiting := false;
438			end;
439			inherited DoExit;
440			end;
441
442			procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
443			begin
444			inherited KeyUp(Key, Shift);
445			if Key = VK_RETURN then
446			EditingDone
447			else
448			if Key = VK_ESCAPE then
449			begin
450			SelStart := UTF8Length(Text); {Ensure end of line selection}
451			ResetParser;
452			Text := FOriginalTextValue;
453			SelectAll;
454			end
455			else
456			if (IsEditableTextKey(Key) or (Key = VK_BACK))
457			and AutoComplete and (Style <> csDropDownList) and
458			(not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
459			FTimer.Interval := FKeyPressInterval
460			else
461			FTimer.Interval := 0
462			end;
463
464			procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
465			begin
466			inherited SetItemIndex(Val);
467			FLastKeyValue := KeyValue;
468			end;
469
470			procedure TIBLookupComboEditBox.UpdateShowing;
471			begin
472			inherited UpdateShowing;
473			if Showing then {Ensure up-to-date as we were ignoring any changes}
474			ActiveChanged(nil);
475			end;
476
477			constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
478			begin
479			inherited Create(TheComponent);
480			FDataLink := TIBLookupComboDataLink.Create(self);
481			FKeyPressInterval := 500;
482			FAutoComplete := true;
483			FTimer := TTimer.Create(nil);
484			FTimer.Interval := 0;
485			FTimer.OnTimer := @HandleTimer;
486			FLastKeyValue := NULL;
487			end;
488
489			destructor TIBLookupComboEditBox.Destroy;
490			begin
491			if assigned(FDataLink) then FDataLink.Free;
492			if assigned(FTimer) then FTimer.Free;
493			inherited Destroy;
494			end;
495
496			procedure TIBLookupComboEditBox.EditingDone;
497			begin
498			CheckAndInsert;
499			inherited EditingDone;
500			end;
501
502			end.