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 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;
    FLastKeyValue: variant;
    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;

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

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

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

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

procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
begin
   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 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;
end;

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

procedure TIBLookupComboEditBox.DoExit;
begin
  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
  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
  else
    FTimer.Interval := 0;
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
  CheckAndInsert;
  inherited EditingDone;
end;

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