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;
    FModified: boolean;
    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;
    procedure UpdateData(Sender: TObject); 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;
    FModified := true;
  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;

procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
begin
  inherited UpdateData(Sender);
  FModified := false;
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;
  Application.RemoveAsyncCalls(self);
  inherited Destroy;
end;

procedure TIBLookupComboEditBox.EditingDone;
begin
  FForceAutoComplete := true;
  try
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  finally
    FForceAutoComplete := false;
  end;
  CheckAndInsert;
  if FModified then
    Change; {ensure Update}
  inherited EditingDone;
end;

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