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