trunk/ibcontrols/IBLookupComboEditBox.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit IBLookupComboEditBox;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
  ExtCtrls, IBSQLParser, DB, StdCtrls, 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;
           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.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:	29
Committed:	Sat May 9 11:37:49 2015 UTC (9 years, 7 months ago) by tony
Content type:	text/x-pascal
File size:	16261 byte(s)
Log Message:	Committing updates for Release R1-2-4
#	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	end;
351	end;
352	finally
353	FUpdating := false
354	end;
355	end;
356	end;
357
358	procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
359	Parser: TSelectSQLParser);
360	var FieldPosition: integer;
361	begin
362	if FFiltered then
363	begin
364	if cbactSearchCaseSensitive in AutoCompleteText then
365	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
366	SQLSafe(Text) + '%''')
367	else
368	Parser.Add2WhereClause(GetRelationNameQualifier + 'Upper("' + ListField + '") Like Upper(''' +
369	SQLSafe(Text) + '%'')');
370
371	end;
372	if cbactSearchAscending in AutoCompleteText then
373	begin
374	FieldPosition := Parser.GetFieldPosition(ListField);
375	if FieldPosition = 0 then Exit;
376
377	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
378	end;
379	end;
380
381	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
382	begin
383	SelectAll
384	end;
385
386	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
387	begin
388	if FInserting then
389	ListSource.DataSet.FieldByName(ListField).AsString := Text
390	end;
391
392	procedure TIBLookupComboEditBox.CheckAndInsert;
393	var Accept: boolean;
394	NewKeyValue: variant;
395	begin
396	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
397	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
398	try
399	{Is it OK to insert a new list member?}
400	Accept := true;
401	if assigned(FOnCanAutoInsert) then
402	OnCanAutoInsert(self,Text,Accept);
403	if not Accept then
404	begin
405	ResetParser;
406	Text := FOriginalTextValue;
407	SelectAll;
408	Exit;
409	end;
410
411	FInserting := true;
412	try
413	{New Value}
414	FFiltered := false;
415	if assigned(FOnAutoInsert) then
416	begin
417	{In an OnAutoInsert handler, the client is expected to insert the new
418	row into the List DataSet and to set the KeyValue property to the
419	value of the primary key of the new row.}
420	OnAutoInsert(self,Text,NewKeyValue);
421	end
422	else
423	begin
424	ListSource.DataSet.Append;
425	{The new KeyValue should be determined by an external generator or
426	in the "OnInsert" handler. If it is the same as the ListField, then
427	it will be set from the UpdateLinkData method}
428	try
429	ListSource.DataSet.Post;
430	except
431	ListSource.DataSet.Cancel;
432	raise;
433	end;
434	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
435	end;
436	Text := ''; {Ensure full list}
437	UpdateList;
438	KeyValue := NewKeyValue;
439	UpdateData(nil); {Force sync with DataField}
440	finally
441	FInserting := false
442	end;
443	except
444	Text := FOriginalTextValue;
445	ResetParser;
446	raise;
447	end;
448	end;
449
450	procedure TIBLookupComboEditBox.DoEnter;
451	begin
452	inherited DoEnter;
453	FOriginalTextValue:= Text;
454	ResetParser;
455	Application.QueueAsyncCall(@HandleEnter,0);
456	end;
457
458	procedure TIBLookupComboEditBox.DoExit;
459	begin
460	FExiting := true;
461	try
462	CheckAndInsert;
463	ResetParser;
464	FTimer.Interval := 0;
465	finally
466	FExiting := false;
467	end;
468	inherited DoExit;
469	end;
470
471	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
472	begin
473	inherited KeyUp(Key, Shift);
474	if Key = VK_RETURN then
475	EditingDone
476	else
477	if Key = VK_ESCAPE then
478	begin
479	SelStart := UTF8Length(Text); {Ensure end of line selection}
480	ResetParser;
481	Text := FOriginalTextValue;
482	SelectAll;
483	end
484	else
485	if (IsEditableTextKey(Key) or (Key = VK_BACK))
486	and AutoComplete and (Style <> csDropDownList) and
487	(not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
488	FTimer.Interval := FKeyPressInterval
489	else
490	FTimer.Interval := 0;
491	end;
492
493	procedure TIBLookupComboEditBox.Loaded;
494	begin
495	inherited Loaded;
496	IBControlLinkChanged;
497	end;
498
499	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
500	Operation: TOperation);
501	begin
502	inherited Notification(AComponent, Operation);
503	if (Operation = opRemove) and (AComponent = DataSource) then
504	ListSource := nil;
505	end;
506
507	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
508	begin
509	inherited SetItemIndex(Val);
510	FLastKeyValue := KeyValue;
511	end;
512
513	function TIBLookupComboEditBox.SQLSafe(aText: string): string;
514	var I: integer;
515	begin
516	Result := '';
517	for I := 1 to length(aText) do
518	if aText[I] = '''' then
519	Result := Result + ''''''
520	else
521	Result := Result + aText[I];
522	end;
523
524	procedure TIBLookupComboEditBox.UpdateShowing;
525	begin
526	inherited UpdateShowing;
527	if Showing then {Ensure up-to-date as we were ignoring any changes}
528	ActiveChanged(nil);
529	end;
530
531	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
532	begin
533	inherited Create(TheComponent);
534	FDataLink := TIBLookupComboDataLink.Create(self);
535	FIBLookupControlLink := TIBLookupControlLink.Create(self);
536	FKeyPressInterval := 200;
537	FAutoComplete := true;
538	FTimer := TTimer.Create(nil);
539	FTimer.Interval := 0;
540	FTimer.OnTimer := @HandleTimer;
541	FLastKeyValue := NULL;
542	end;
543
544	destructor TIBLookupComboEditBox.Destroy;
545	begin
546	if assigned(FDataLink) then FDataLink.Free;
547	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
548	if assigned(FTimer) then FTimer.Free;
549	inherited Destroy;
550	end;
551
552	procedure TIBLookupComboEditBox.EditingDone;
553	begin
554	CheckAndInsert;
555	inherited EditingDone;
556	end;
557
558	end.