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 >= 2000002}
    {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}
    {$if lcl_fullversion = 2000002}
    procedure UTF8KeyPress(var UTF8Key: TUTF8Char); 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;


{Workarounds due to bugs in various Lazarus 2.0 release candidates}
{$if lcl_fullversion >= 2000002}
type

  { THackedCustomComboBox }

  THackedCustomComboBox = class(TCustomComboBox)
  private
    procedure CallChange;
    procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
  end;

{ THackedCustomComboBox }

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
end;

procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  inherited UTF8KeyPress(UTF8Key);
end;

procedure TIBLookupComboEditBox.Change;
begin
  if DataSource = nil 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 DataSource = nil 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 DataSource = nil then
    Result := true
  else
    Result := inherited DoEdit;
end;
{$ifend}

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