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, LCLVersion;

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;
    FCurText: string;
    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, LazUTF8;

{ 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;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FCurText := Text;
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := FCurText;
         if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> FCurText) 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
           else
           begin
             SelStart := iSelStart;
             SelLength := 0;
           end;
         end;
    finally
      FUpdating := false
    end;
  end;
end;

procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
  Parser: TSelectSQLParser);
var FieldPosition: integer;
    FilterText: string;
begin
  if FFiltered then
  begin
    if FUpdating then
      FilterText := FCurText
    else
      FilterText := Text;
    if cbactSearchCaseSensitive in AutoCompleteText then
      Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
                                  SQLSafe(FilterText) + '%''')
    else
      Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' +  ListField + '") Like Upper(''' +
                                  SQLSafe(FilterText) + '%'')');

    if cbactSearchAscending in AutoCompleteText then
    begin
      FieldPosition := Parser.GetFieldPosition(ListField);
      if FieldPosition = 0 then Exit;

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