trunk/ibcontrols/IBLookupComboEditBox.pas

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

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
  ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet;

type

  {TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
   of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
   to revise the available list and restrict it to items that are prefixed by the
   typed text (either case sensitive or case insenstive). Autoinsert allows a
   newly typed entry to be added to the list dataset and included in the available
   list items.    }

  TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
  TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;

  TIBLookupComboEditBox = class;

  { TIBLookupComboDataLink }

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