journaling/ibcontrols/IBLookupComboEditBox.pas

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

{$mode objfpc}{$H+}

interface

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

type

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

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

  TIBLookupComboEditBox = class;

  { TIBLookupComboDataLink }

  TIBLookupComboDataLink = class(TDataLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure ActiveChanged; override;
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;

  { TIBLookupControlLink }

  TIBLookupControlLink = class(TIBControlLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure UpdateSQL(Sender: TObject); override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    FCanAutoInsert: TCanAutoInsert;
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FIBLookupControlLink: TIBLookupControlLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: boolean;
    FLastKeyValue: variant;
    FCurText: string;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    function SQLSafe(aText: string): string;
    procedure UpdateShowing; override;

  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    procedure EditingDone; override;
  published
    { Published declarations }
    property AutoInsert: boolean read FAutoInsert write FAutoInsert;
    property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
    property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
             write SetAutoCompleteText;
    property ItemHeight;
    property ItemWidth;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
    property RelationName: string read FRelationName write FRelationName;
    property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
    property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
  end;


implementation

uses IBQuery, LCLType, Variants, LCLProc, LazUTF8;

{ TIBLookupControlLink }

constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
begin
  inherited Create;
  FOwner := AOwner;
end;

procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
begin
  FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
end;

{ TIBLookupComboDataLink }

procedure TIBLookupComboDataLink.ActiveChanged;
begin
  FOwner.ActiveChanged(self)
end;

procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
begin
  FOwner.RecordChanged(self,Field);
end;

procedure TIBLookupComboDataLink.UpdateData;
begin
  FOwner.UpdateLinkData(self)
end;

constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
begin
  inherited Create;
  FOwner := AOwner
end;

{ TIBLookupComboEditBox }

procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
var ActiveState: boolean;
begin
  FTimer.Interval := 0;
  FFiltered := Text <> '';
  UpdateList
end;

procedure TIBLookupComboEditBox.IBControlLinkChanged;
begin
  if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
    FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
  else
    FIBLookupControlLink.IBDataSet := nil;
end;

function TIBLookupComboEditBox.GetListSource: TDataSource;
begin
  Result := inherited ListSource;
end;

function TIBLookupComboEditBox.GetRelationNameQualifier: string;
begin
  if FRelationName <> '' then
     Result := FRelationName + '.'
  else
    Result := ''
end;

procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
begin
  if not FInserting and not FUpdating then
     Application.QueueAsyncCall(@DoActiveChanged,0);
  IBControlLinkChanged;
end;

procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;

  if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
     and ListSource.DataSet.Active   then
  begin
    begin
      if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
        KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
      else
      begin
        KeyValue := FLastKeyValue;
        UpdateData(self); {Force auto scroll}
        if varIsNull(KeyValue) then {Value not present}
          Text := ListSource.DataSet.FieldByName(ListField).AsString
      end;
    end;
  end
  else
  if (DataSource <> nil) and  assigned(DataSource.DataSet) and
                   (DataSource.DataSet.Active) and (DataField <> '') then
  begin
    ResetParser;
    KeyValue := Field.AsVariant;
  end
  else
    Text := '';
  FOriginalTextValue := Text;
end;

function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
begin
  Result := inherited AutoCompleteText;
  if AutoComplete then
     Result := Result + [cbactEnabled]
end;

procedure TIBLookupComboEditBox.ResetParser;
var curKeyValue: variant;
begin
  if FFiltered then
  begin
    FFiltered := false;
    curKeyValue := KeyValue;
    Text := ''; {Ensure full list}
    UpdateList;
    KeyValue := curKeyValue;
    UpdateData(self); {Force Scroll}
  end;
end;

procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
begin
  {Make sure that we are in sync with other data controls}
  if DataSource = nil then
  begin
    KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
    if VarIsNull(KeyValue) then {Probable deletion}
    begin
      UpdateList;
      KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
    end;
  end;
end;

procedure TIBLookupComboEditBox.SetAutoCompleteText(
  AValue: TComboBoxAutoCompleteText);
begin
  if AValue <> AutoCompleteText then
  begin
    FAutoComplete := cbactEnabled in AValue;
    inherited AutoCompleteText := AValue - [cbactEnabled]
  end;
end;

procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
begin
  if AValue <> inherited ListSource then
  begin
    FDataLink.DataSource := AValue;
    inherited ListSource := AValue;
    IBControlLinkChanged;
  end;
end;

procedure TIBLookupComboEditBox.UpdateList;
{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
  ListSource DataSet as the source for the autocomplete text. It also runs
  after a delay rather than immediately on keyup
}
var
  iSelStart: Integer; // char position
  sCompleteText, sPrefixText, sResultText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FCurText := Text;
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := FCurText;
         if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> FCurText) then
             begin
               sResultText := sCompleteText;
               if ((cbactEndOfLineComplete in AutoCompleteText) and
                         (cbactRetainPrefixCase in AutoCompleteText)) then
               begin//Retain Prefix Character cases
                 UTF8Delete(sResultText, 1, iSelStart);
                 UTF8Insert(sPrefixText, sResultText, 1);
               end;
               Text := sResultText;
               SelStart := iSelStart;
               SelLength := UTF8Length(Text);
             end;
             KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           end;
         end;
    finally
      FUpdating := false
    end;
  end;
end;

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

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

      Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
    end;
  end;
end;

procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
begin
  if AppDestroying in Application.Flags then Exit;
   SelectAll
end;

procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
begin
  if FInserting then
    ListSource.DataSet.FieldByName(ListField).AsString := Text
end;

procedure TIBLookupComboEditBox.CheckAndInsert;
var Accept: boolean;
    NewKeyValue: variant;
begin
  if FInCheckAndInsert then Exit;
  FInCheckAndInsert := true;
  try
       if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
          and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
       try
         {Is it OK to insert a new list member?}
         Accept := true;
         if assigned(FOnCanAutoInsert) then
            OnCanAutoInsert(self,Text,Accept);
         if not Accept then
         begin
           ResetParser;
           Text := FOriginalTextValue;
           SelectAll;
           Exit;
         end;

         FInserting := true;
         try
           {New Value}
           FFiltered := false;
           if assigned(FOnAutoInsert) then
           begin
             {In an OnAutoInsert handler, the client is expected to insert the new
              row into the List DataSet and to set the KeyValue property to the
              value of the primary key of the new row.}
             OnAutoInsert(self,Text,NewKeyValue);
           end
           else
           begin
             ListSource.DataSet.Append;
             {The new KeyValue should be determined by an external generator or
              in the "OnInsert" handler. If it is the same as the ListField, then
              it will be set from the UpdateLinkData method}
             try
               ListSource.DataSet.Post;
             except
               ListSource.DataSet.Cancel;
               raise;
             end;
             NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           end;
           Text := ''; {Ensure full list}
           UpdateList;
           KeyValue := NewKeyValue;
           UpdateData(nil); {Force sync with DataField}
         finally
           FInserting := false
         end;
       except
         Text := FOriginalTextValue;
         ResetParser;
         raise;
       end;
  finally
    FInCheckAndInsert := false
  end;
end;

procedure TIBLookupComboEditBox.DoEnter;
begin
  inherited DoEnter;
  FOriginalTextValue:= Text;
  ResetParser;
  Application.QueueAsyncCall(@HandleEnter,0);
end;

procedure TIBLookupComboEditBox.DoExit;
begin
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  FExiting := true;
  try
    CheckAndInsert;
    ResetParser;
    FTimer.Interval := 0;
  finally
    FExiting := false;
  end;
  inherited DoExit;
end;

procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);
  if Key = VK_RETURN then
     EditingDone
  else
  if Key = VK_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  begin
    FTimer.Interval := 0;
    if (IsEditableTextKey(Key) or (Key = VK_BACK))
       and AutoComplete and (Style <> csDropDownList) and
       (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
      FTimer.Interval := FKeyPressInterval;
  end;
end;

procedure TIBLookupComboEditBox.Loaded;
begin
  inherited Loaded;
  IBControlLinkChanged;
end;

procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = DataSource) then
    ListSource := nil;
end;

procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
begin
  inherited SetItemIndex(Val);
  FLastKeyValue := KeyValue;
end;

function TIBLookupComboEditBox.SQLSafe(aText: string): string;
var I: integer;
begin
  Result := '';
  for I := 1 to length(aText) do
    if aText[I] = '''' then
      Result := Result + ''''''
    else
      Result := Result + aText[I];
end;

procedure TIBLookupComboEditBox.UpdateShowing;
begin
  inherited UpdateShowing;
  if Showing then {Ensure up-to-date as we were ignoring any changes}
    ActiveChanged(nil);
end;

constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
begin
  inherited Create(TheComponent);
  FDataLink := TIBLookupComboDataLink.Create(self);
  FIBLookupControlLink := TIBLookupControlLink.Create(self);
  FKeyPressInterval := 200;
  FAutoComplete := true;
  FTimer := TTimer.Create(nil);
  FTimer.Interval := 0;
  FTimer.OnTimer := @HandleTimer;
  FLastKeyValue := NULL;
end;

destructor TIBLookupComboEditBox.Destroy;
begin
  if assigned(FDataLink) then FDataLink.Free;
  if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
  if assigned(FTimer) then FTimer.Free;
  inherited Destroy;
end;

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

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