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;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: 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 (FForceAutoComplete or 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('Upper(' + GetRelationNameQualifier + '"' +  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 FInCheckAndInsert then Exit;
  FInCheckAndInsert := true;
  try
       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;
  finally
    FInCheckAndInsert := false
  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
  begin
    FTimer.Interval := 0;
    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;
  end;
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
  FForceAutoComplete := true;
  try
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  finally
    FForceAutoComplete := false;
  end;
  CheckAndInsert;
  inherited EditingDone;
end;

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