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, LCLType, 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;
    {$if lcl_fullversion < 2000003}
    procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
    {$endif}
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;

  { TIBLookupControlLink }

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


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FIBLookupControlLink: TIBLookupControlLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: boolean;
    FLastKeyValue: variant;
    FCurText: string;
    FModified: boolean;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    {$if lcl_fullversion >= 2000003}
    {Deferred update changes in Lazarus 2.0 stop the combo box working when
     the datasource is nil. We thus have to reverse out the changes :(}
    function DoEdit: boolean; override;
    procedure Change; override;
    procedure CloseUp; override;
    procedure Select; override;
    {$ifend}
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetItemIndex(const Val: integer); override;
    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 Variants, LCLProc, LazUTF8, IBUtils;

{ 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;

{$if lcl_fullversion < 2000003}
procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
begin
  inherited DataEvent(Event, Info);
  if Event = deLayoutChange then
   FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
end;
{$endif}

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

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

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

{ TIBLookupComboEditBox }

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

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

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

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

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

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

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

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

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

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

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

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

procedure TIBLookupComboEditBox.UpdateList;
{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
  ListSource DataSet as the source for the autocomplete text. It also runs
  after a delay rather than immediately on keyup
}
var
  iSelStart: Integer; // char position
  sCompleteText, sPrefixText, sResultText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FCurText := Text;
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := FCurText;
         if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> FCurText) then
             begin
               KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
               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) - iSelStart;
             end;
           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 ''' +
                                  SQLSafeString(FilterText) + '%''')
    else
      Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' +  ListField + '") Like Upper(''' +
                                  SQLSafeString(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_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  if AutoComplete and (Style <> csDropDownList) then
  begin
    if (Key = VK_BACK) or (Key = VK_DELETE) then
    begin
      if SelStart = 0 then
      begin
        SelStart := UTF8Length(Text);
        SelLength := 0;
      end;
      FTimer.Interval := 0;
    end
    else
    if IsEditableTextKey(Key) and
     (not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
    begin
      FTimer.Interval := 0;
      FTimer.Interval := FKeyPressInterval;
    end;
  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
  if Val > 0 then
    FCurText := '';
  inherited SetItemIndex(Val);
  FLastKeyValue := KeyValue;
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);
  if FCurText <> '' then
    Text := FCurText + Text;
  FModified := false;
end;

{$if lcl_fullversion >= 2000003}
type

  { THackedCustomComboBox }

  THackedCustomComboBox = class(TCustomComboBox)
  private
    procedure CallChange;
  end;

{ THackedCustomComboBox }

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
end;

procedure TIBLookupComboEditBox.Change;
begin
  if IsUnbound then
    THackedCustomComboBox(self).CallChange
  else
    inherited Change;
end;

procedure TIBLookupComboEditBox.CloseUp;
begin
  inherited DoEdit;
  inherited CloseUp;
  EditingDone;
end;

procedure TIBLookupComboEditBox.Select;
begin
  inherited Select;
  if IsUnbound then
    inherited DoEdit;
end;

function TIBLookupComboEditBox.DoEdit: boolean;
begin
  {DoEdit will swallow characters if no editable Field. Hence, to enabled
   writing we must avoid calling the inherited method.}
  if IsUnbound then
    Result := true
  else
    Result := inherited DoEdit;
end;
{$ifend}

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;
  FCurText := '';
  if FModified then
    Change; {ensure Update}
  inherited EditingDone;
end;

end.
Revision:	272
Committed:	Mon Feb 4 13:34:37 2019 UTC (5 years, 10 months ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/ibcontrols/IBLookupComboEditBox.pas*
File size:	19241 byte(s)
Log Message:	Fixes merged
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26	unit IBLookupComboEditBox;
27
28	{$mode objfpc}{$H+}
29
30	interface
31
32	uses
33	Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35
36	type
37
38	{TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
39	of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
40	to revise the available list and restrict it to items that are prefixed by the
41	typed text (either case sensitive or case insenstive). Autoinsert allows a
42	newly typed entry to be added to the list dataset and included in the available
43	list items. }
44
45	TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
46	TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;
47
48	TIBLookupComboEditBox = class;
49
50	{ TIBLookupComboDataLink }
51
52	TIBLookupComboDataLink = class(TDataLink)
53	private
54	FOwner: TIBLookupComboEditBox;
55	protected
56	procedure ActiveChanged; override;
57	{$if lcl_fullversion < 2000003}
58	procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
59	{$endif}
60	procedure RecordChanged(Field: TField); override;
61	procedure UpdateData; override;
62	public
63	constructor Create(AOwner: TIBLookupComboEditBox);
64	end;
65
66	{ TIBLookupControlLink }
67
68	TIBLookupControlLink = class(TIBControlLink)
69	private
70	FOwner: TIBLookupComboEditBox;
71	protected
72	procedure UpdateSQL(Sender: TObject); override;
73	public
74	constructor Create(AOwner: TIBLookupComboEditBox);
75	end;
76
77
78	{ TIBLookupComboEditBox }
79
80	TIBLookupComboEditBox = class(TDBLookupComboBox)
81	private
82	{ Private declarations }
83	FDataLink: TIBLookupComboDataLink;
84	FIBLookupControlLink: TIBLookupControlLink;
85	FAutoComplete: boolean;
86	FAutoInsert: boolean;
87	FKeyPressInterval: integer;
88	FOnCanAutoInsert: TCanAutoInsert;
89	FRelationName: string;
90	FTimer: TTimer;
91	FFiltered: boolean;
92	FOnAutoInsert: TAutoInsert;
93	FOriginalTextValue: string;
94	FUpdating: boolean;
95	FInserting: boolean;
96	FExiting: boolean;
97	FForceAutoComplete: boolean;
98	FInCheckAndInsert: boolean;
99	FLastKeyValue: variant;
100	FCurText: string;
101	FModified: boolean;
102	procedure DoActiveChanged(Data: PtrInt);
103	function GetAutoCompleteText: TComboBoxAutoCompleteText;
104	function GetListSource: TDataSource;
105	function GetRelationNameQualifier: string;
106	procedure HandleTimer(Sender: TObject);
107	procedure IBControlLinkChanged;
108	procedure ResetParser;
109	procedure RecordChanged(Sender: TObject; aField: TField);
110	procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
111	procedure SetListSource(AValue: TDataSource);
112	procedure UpdateList;
113	procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
114	procedure HandleEnter(Data: PtrInt);
115	procedure UpdateLinkData(Sender: TObject);
116	protected
117	{ Protected declarations }
118	procedure ActiveChanged(Sender: TObject);
119	procedure CheckAndInsert;
120	procedure DoEnter; override;
121	procedure DoExit; override;
122	{$if lcl_fullversion >= 2000003}
123	{Deferred update changes in Lazarus 2.0 stop the combo box working when
124	the datasource is nil. We thus have to reverse out the changes :(}
125	function DoEdit: boolean; override;
126	procedure Change; override;
127	procedure CloseUp; override;
128	procedure Select; override;
129	{$ifend}
130	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
131	procedure Loaded; override;
132	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
133	procedure SetItemIndex(const Val: integer); override;
134	procedure UpdateShowing; override;
135	procedure UpdateData(Sender: TObject); override;
136	public
137	{ Public declarations }
138	constructor Create(TheComponent: TComponent); override;
139	destructor Destroy; override;
140	procedure EditingDone; override;
141	published
142	{ Published declarations }
143	property AutoInsert: boolean read FAutoInsert write FAutoInsert;
144	property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
145	property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
146	write SetAutoCompleteText;
147	property ItemHeight;
148	property ItemWidth;
149	property ListSource: TDataSource read GetListSource write SetListSource;
150	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
151	property RelationName: string read FRelationName write FRelationName;
152	property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
153	property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
154	end;
155
156
157	implementation
158
159	uses Variants, LCLProc, LazUTF8, IBUtils;
160
161	{ TIBLookupControlLink }
162
163	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
164	begin
165	inherited Create;
166	FOwner := AOwner;
167	end;
168
169	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
170	begin
171	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
172	end;
173
174	{ TIBLookupComboDataLink }
175
176	procedure TIBLookupComboDataLink.ActiveChanged;
177	begin
178	FOwner.ActiveChanged(self)
179	end;
180
181	{$if lcl_fullversion < 2000003}
182	procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
183	begin
184	inherited DataEvent(Event, Info);
185	if Event = deLayoutChange then
186	FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
187	end;
188	{$endif}
189
190	procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
191	begin
192	FOwner.RecordChanged(self,Field);
193	end;
194
195	procedure TIBLookupComboDataLink.UpdateData;
196	begin
197	FOwner.UpdateLinkData(self)
198	end;
199
200	constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
201	begin
202	inherited Create;
203	FOwner := AOwner
204	end;
205
206	{ TIBLookupComboEditBox }
207
208	procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
209	begin
210	FTimer.Interval := 0;
211	FFiltered := Text <> '';
212	UpdateList
213	end;
214
215	procedure TIBLookupComboEditBox.IBControlLinkChanged;
216	begin
217	if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
218	FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
219	else
220	FIBLookupControlLink.IBDataSet := nil;
221	end;
222
223	function TIBLookupComboEditBox.GetListSource: TDataSource;
224	begin
225	Result := inherited ListSource;
226	end;
227
228	function TIBLookupComboEditBox.GetRelationNameQualifier: string;
229	begin
230	if FRelationName <> '' then
231	Result := FRelationName + '.'
232	else
233	Result := ''
234	end;
235
236	procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
237	begin
238	if not FInserting and not FUpdating then
239	Application.QueueAsyncCall(@DoActiveChanged,0);
240	IBControlLinkChanged;
241	end;
242
243	procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
244	begin
245	if AppDestroying in Application.Flags then Exit;
246
247	if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
248	and ListSource.DataSet.Active then
249	begin
250	begin
251	if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
252	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
253	else
254	begin
255	KeyValue := FLastKeyValue;
256	UpdateData(self); {Force auto scroll}
257	if varIsNull(KeyValue) then {Value not present}
258	Text := ListSource.DataSet.FieldByName(ListField).AsString
259	end;
260	end;
261	end
262	else
263	if (DataSource <> nil) and assigned(DataSource.DataSet) and
264	(DataSource.DataSet.Active) and (DataField <> '') then
265	begin
266	ResetParser;
267	KeyValue := Field.AsVariant;
268	end
269	else
270	Text := '';
271	FOriginalTextValue := Text;
272	end;
273
274	function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
275	begin
276	Result := inherited AutoCompleteText;
277	if AutoComplete then
278	Result := Result + [cbactEnabled]
279	end;
280
281	procedure TIBLookupComboEditBox.ResetParser;
282	var curKeyValue: variant;
283	begin
284	if FFiltered then
285	begin
286	FFiltered := false;
287	curKeyValue := KeyValue;
288	Text := ''; {Ensure full list}
289	UpdateList;
290	KeyValue := curKeyValue;
291	UpdateData(self); {Force Scroll}
292	end;
293	end;
294
295	procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
296	begin
297	{Make sure that we are in sync with other data controls}
298	if DataSource = nil then
299	begin
300	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
301	if VarIsNull(KeyValue) then {Probable deletion}
302	begin
303	UpdateList;
304	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
305	end;
306	end;
307	end;
308
309	procedure TIBLookupComboEditBox.SetAutoCompleteText(
310	AValue: TComboBoxAutoCompleteText);
311	begin
312	if AValue <> AutoCompleteText then
313	begin
314	FAutoComplete := cbactEnabled in AValue;
315	inherited AutoCompleteText := AValue - [cbactEnabled]
316	end;
317	end;
318
319	procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
320	begin
321	if AValue <> inherited ListSource then
322	begin
323	FDataLink.DataSource := AValue;
324	inherited ListSource := AValue;
325	IBControlLinkChanged;
326	end;
327	end;
328
329	procedure TIBLookupComboEditBox.UpdateList;
330	{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
331	ListSource DataSet as the source for the autocomplete text. It also runs
332	after a delay rather than immediately on keyup
333	}
334	var
335	iSelStart: Integer; // char position
336	sCompleteText, sPrefixText, sResultText: string;
337	begin
338	if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
339	and ListSource.DataSet.Active then
340	begin
341	FCurText := Text;
342	FUpdating := true;
343	try
344	iSelStart := SelStart;//Capture original cursor position
345	if ((iSelStart < UTF8Length(Text)) and
346	(cbactEndOfLineComplete in AutoCompleteText)) then
347	Exit;
348	sPrefixText := UTF8Copy(Text, 1, iSelStart);
349	ListSource.DataSet.Active := false;
350	ListSource.DataSet.Active := true;
351	Text := FCurText;
352	if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
353	begin
354	if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
355	begin
356	sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
357	if (sCompleteText <> FCurText) then
358	begin
359	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
360	sResultText := sCompleteText;
361	if ((cbactEndOfLineComplete in AutoCompleteText) and
362	(cbactRetainPrefixCase in AutoCompleteText)) then
363	begin//Retain Prefix Character cases
364	UTF8Delete(sResultText, 1, iSelStart);
365	UTF8Insert(sPrefixText, sResultText, 1);
366	end;
367	Text := sResultText;
368	SelStart := iSelStart;
369	SelLength := UTF8Length(Text) - iSelStart;
370	end;
371	end
372	else
373	begin
374	SelStart := iSelStart;
375	SelLength := 0;
376	end;
377	end;
378	finally
379	FUpdating := false
380	end;
381	FModified := true;
382	end;
383	end;
384
385	procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
386	Parser: TSelectSQLParser);
387	var FieldPosition: integer;
388	FilterText: string;
389	begin
390	if FFiltered then
391	begin
392	if FUpdating then
393	FilterText := FCurText
394	else
395	FilterText := Text;
396	if cbactSearchCaseSensitive in AutoCompleteText then
397	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
398	SQLSafeString(FilterText) + '%''')
399	else
400	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
401	SQLSafeString(FilterText) + '%'')');
402
403	if cbactSearchAscending in AutoCompleteText then
404	begin
405	FieldPosition := Parser.GetFieldPosition(ListField);
406	if FieldPosition = 0 then Exit;
407
408	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
409	end;
410	end;
411	end;
412
413	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
414	begin
415	if AppDestroying in Application.Flags then Exit;
416	SelectAll
417	end;
418
419	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
420	begin
421	if FInserting then
422	ListSource.DataSet.FieldByName(ListField).AsString := Text
423	end;
424
425	procedure TIBLookupComboEditBox.CheckAndInsert;
426	var Accept: boolean;
427	NewKeyValue: variant;
428	begin
429	if FInCheckAndInsert then Exit;
430	FInCheckAndInsert := true;
431	try
432	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
433	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
434	try
435	{Is it OK to insert a new list member?}
436	Accept := true;
437	if assigned(FOnCanAutoInsert) then
438	OnCanAutoInsert(self,Text,Accept);
439	if not Accept then
440	begin
441	ResetParser;
442	Text := FOriginalTextValue;
443	SelectAll;
444	Exit;
445	end;
446
447	FInserting := true;
448	try
449	{New Value}
450	FFiltered := false;
451	if assigned(FOnAutoInsert) then
452	begin
453	{In an OnAutoInsert handler, the client is expected to insert the new
454	row into the List DataSet and to set the KeyValue property to the
455	value of the primary key of the new row.}
456	OnAutoInsert(self,Text,NewKeyValue);
457	end
458	else
459	begin
460	ListSource.DataSet.Append;
461	{The new KeyValue should be determined by an external generator or
462	in the "OnInsert" handler. If it is the same as the ListField, then
463	it will be set from the UpdateLinkData method}
464	try
465	ListSource.DataSet.Post;
466	except
467	ListSource.DataSet.Cancel;
468	raise;
469	end;
470	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
471	end;
472	Text := ''; {Ensure full list}
473	UpdateList;
474	KeyValue := NewKeyValue;
475	UpdateData(nil); {Force sync with DataField}
476	finally
477	FInserting := false
478	end;
479	except
480	Text := FOriginalTextValue;
481	ResetParser;
482	raise;
483	end;
484	finally
485	FInCheckAndInsert := false
486	end;
487	end;
488
489	procedure TIBLookupComboEditBox.DoEnter;
490	begin
491	inherited DoEnter;
492	FOriginalTextValue:= Text;
493	ResetParser;
494	Application.QueueAsyncCall(@HandleEnter,0);
495	end;
496
497	procedure TIBLookupComboEditBox.DoExit;
498	begin
499	if FTimer.Interval <> 0 then
500	HandleTimer(nil);
501	FExiting := true;
502	try
503	CheckAndInsert;
504	ResetParser;
505	FTimer.Interval := 0;
506	finally
507	FExiting := false;
508	end;
509	inherited DoExit;
510	end;
511
512	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
513	begin
514	inherited KeyUp(Key, Shift);
515	if Key = VK_ESCAPE then
516	begin
517	SelStart := UTF8Length(Text); {Ensure end of line selection}
518	ResetParser;
519	Text := FOriginalTextValue;
520	SelectAll;
521	end
522	else
523	if AutoComplete and (Style <> csDropDownList) then
524	begin
525	if (Key = VK_BACK) or (Key = VK_DELETE) then
526	begin
527	if SelStart = 0 then
528	begin
529	SelStart := UTF8Length(Text);
530	SelLength := 0;
531	end;
532	FTimer.Interval := 0;
533	end
534	else
535	if IsEditableTextKey(Key) and
536	(not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
537	begin
538	FTimer.Interval := 0;
539	FTimer.Interval := FKeyPressInterval;
540	end;
541	end;
542	end;
543
544	procedure TIBLookupComboEditBox.Loaded;
545	begin
546	inherited Loaded;
547	IBControlLinkChanged;
548	end;
549
550	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
551	Operation: TOperation);
552	begin
553	inherited Notification(AComponent, Operation);
554	if (Operation = opRemove) and (AComponent = DataSource) then
555	ListSource := nil;
556	end;
557
558	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
559	begin
560	if Val > 0 then
561	FCurText := '';
562	inherited SetItemIndex(Val);
563	FLastKeyValue := KeyValue;
564	end;
565
566	procedure TIBLookupComboEditBox.UpdateShowing;
567	begin
568	inherited UpdateShowing;
569	if Showing then {Ensure up-to-date as we were ignoring any changes}
570	ActiveChanged(nil);
571	end;
572
573	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
574	begin
575	inherited UpdateData(Sender);
576	if FCurText <> '' then
577	Text := FCurText + Text;
578	FModified := false;
579	end;
580
581	{$if lcl_fullversion >= 2000003}
582	type
583
584	{ THackedCustomComboBox }
585
586	THackedCustomComboBox = class(TCustomComboBox)
587	private
588	procedure CallChange;
589	end;
590
591	{ THackedCustomComboBox }
592
593	procedure THackedCustomComboBox.CallChange;
594	begin
595	inherited Change;
596	end;
597
598	procedure TIBLookupComboEditBox.Change;
599	begin
600	if IsUnbound then
601	THackedCustomComboBox(self).CallChange
602	else
603	inherited Change;
604	end;
605
606	procedure TIBLookupComboEditBox.CloseUp;
607	begin
608	inherited DoEdit;
609	inherited CloseUp;
610	EditingDone;
611	end;
612
613	procedure TIBLookupComboEditBox.Select;
614	begin
615	inherited Select;
616	if IsUnbound then
617	inherited DoEdit;
618	end;
619
620	function TIBLookupComboEditBox.DoEdit: boolean;
621	begin
622	{DoEdit will swallow characters if no editable Field. Hence, to enabled
623	writing we must avoid calling the inherited method.}
624	if IsUnbound then
625	Result := true
626	else
627	Result := inherited DoEdit;
628	end;
629	{$ifend}
630
631	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
632	begin
633	inherited Create(TheComponent);
634	FDataLink := TIBLookupComboDataLink.Create(self);
635	FIBLookupControlLink := TIBLookupControlLink.Create(self);
636	FKeyPressInterval := 200;
637	FAutoComplete := true;
638	FTimer := TTimer.Create(nil);
639	FTimer.Interval := 0;
640	FTimer.OnTimer := @HandleTimer;
641	FLastKeyValue := NULL;
642	end;
643
644	destructor TIBLookupComboEditBox.Destroy;
645	begin
646	if assigned(FDataLink) then FDataLink.Free;
647	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
648	if assigned(FTimer) then FTimer.Free;
649	Application.RemoveAsyncCalls(self);
650	inherited Destroy;
651	end;
652
653	procedure TIBLookupComboEditBox.EditingDone;
654	begin
655	FForceAutoComplete := true;
656	try
657	if FTimer.Interval <> 0 then
658	HandleTimer(nil);
659	finally
660	FForceAutoComplete := false;
661	end;
662	CheckAndInsert;
663	FCurText := '';
664	if FModified then
665	Change; {ensure Update}
666	inherited EditingDone;
667	end;
668
669	end.