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;
    FModified: boolean;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    function SQLSafe(aText: string): string;
    procedure UpdateShowing; override;
    procedure UpdateData(Sender: TObject); override;
  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    procedure EditingDone; override;
  published
    { Published declarations }
    property AutoInsert: boolean read FAutoInsert write FAutoInsert;
    property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
    property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
             write SetAutoCompleteText;
    property ItemHeight;
    property ItemWidth;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
    property RelationName: string read FRelationName write FRelationName;
    property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
    property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
  end;


implementation

uses IBQuery, LCLType, Variants, LCLProc, LazUTF8;

{ TIBLookupControlLink }

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

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

{ TIBLookupComboDataLink }

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

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

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

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

{ TIBLookupComboEditBox }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
begin
  inherited UpdateData(Sender);
  FModified := false;
end;

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

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

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

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