trunk/ibcontrols/IBLookupComboEditBox.pas

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

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, 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;
    procedure DataEvent(Event: TDataEvent; Info: Ptrint); 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
    { 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;
    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 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.DataEvent(Event: TDataEvent; Info: Ptrint);
begin
  inherited DataEvent(Event, Info);
  if Event = deLayoutChange then
   FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
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);
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 ''' +
                                  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_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;

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);
  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
  THackedCustomComboBox(self).CallChange;
end;

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

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