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;

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