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 Loaded; 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;
             KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           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
  if AppDestroying in Application.Flags then Exit;
   SelectAll
end;

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

procedure TIBLookupComboEditBox.CheckAndInsert;
var Accept: boolean;
    NewKeyValue: variant;
begin
  if 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
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  FExiting := true;
  try
    CheckAndInsert;
    ResetParser;
    FTimer.Interval := 0;
  finally
    FExiting := false;
  end;
  inherited DoExit;
end;

procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);
  if Key = VK_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.Loaded;
begin
  inherited Loaded;
  IBControlLinkChanged;
end;

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

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