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}
    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 >= 2000002}
type

  { THackedCustomComboBox }

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

{ THackedCustomComboBox }

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
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}

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:	275
Committed:	Mon Feb 4 13:41:10 2019 UTC (5 years, 10 months ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/ibcontrols/IBLookupComboEditBox.pas*
File size:	19262 byte(s)
Log Message:	Fixes merged
#	User	Rev	Content
1	tony	21	(*
2			* IBX For Lazarus (Firebird Express)
3			*
4			* The contents of this file are subject to the Initial Developer's
5			* Public License Version 1.0 (the "License"); you may not use this
6			* file except in compliance with the License. You may obtain a copy
7			* of the License here:
8			*
9			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10			*
11			* Software distributed under the License is distributed on an "AS
12			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13			* implied. See the License for the specific language governing rights
14			* and limitations under the License.
15			*
16			* The Initial Developer of the Original Code is Tony Whyman.
17			*
18	tony	23	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	tony	21	* (http://www.mwasoftware.co.uk).
20			*
21			* All Rights Reserved.
22			*
23			* Contributor(s): ______________________________________.
24			*
25			*)
26			unit IBLookupComboEditBox;
27
28			{$mode objfpc}{$H+}
29
30			interface
31
32			uses
33	tony	263	Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34			ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35	tony	21
36			type
37
38			{TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
39			of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
40			to revise the available list and restrict it to items that are prefixed by the
41			typed text (either case sensitive or case insenstive). Autoinsert allows a
42			newly typed entry to be added to the list dataset and included in the available
43			list items. }
44
45			TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
46			TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;
47
48			TIBLookupComboEditBox = class;
49
50			{ TIBLookupComboDataLink }
51
52			TIBLookupComboDataLink = class(TDataLink)
53			private
54			FOwner: TIBLookupComboEditBox;
55			protected
56			procedure ActiveChanged; override;
57	tony	272	{$if lcl_fullversion < 2000003}
58	tony	209	procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
59	tony	272	{$endif}
60	tony	21	procedure RecordChanged(Field: TField); override;
61			procedure UpdateData; override;
62			public
63			constructor Create(AOwner: TIBLookupComboEditBox);
64			end;
65
66	tony	27	{ TIBLookupControlLink }
67	tony	21
68	tony	27	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	tony	21	{ TIBLookupComboEditBox }
79
80			TIBLookupComboEditBox = class(TDBLookupComboBox)
81			private
82			{ Private declarations }
83			FDataLink: TIBLookupComboDataLink;
84	tony	27	FIBLookupControlLink: TIBLookupControlLink;
85	tony	21	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	tony	35	FForceAutoComplete: boolean;
98			FInCheckAndInsert: boolean;
99	tony	21	FLastKeyValue: variant;
100	tony	64	FCurText: string;
101	tony	143	FModified: boolean;
102	tony	21	procedure DoActiveChanged(Data: PtrInt);
103			function GetAutoCompleteText: TComboBoxAutoCompleteText;
104			function GetListSource: TDataSource;
105			function GetRelationNameQualifier: string;
106			procedure HandleTimer(Sender: TObject);
107	tony	27	procedure IBControlLinkChanged;
108	tony	21	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	tony	275	{$if lcl_fullversion >= 2000002}
123	tony	263	{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	tony	21	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
131	tony	29	procedure Loaded; override;
132	tony	27	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
133	tony	21	procedure SetItemIndex(const Val: integer); override;
134			procedure UpdateShowing; override;
135	tony	143	procedure UpdateData(Sender: TObject); override;
136	tony	21	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	tony	27	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
151	tony	21	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	tony	272	uses Variants, LCLProc, LazUTF8, IBUtils;
160	tony	21
161	tony	27	{ TIBLookupControlLink }
162	tony	21
163	tony	27	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
164	tony	21	begin
165	tony	27	inherited Create;
166			FOwner := AOwner;
167	tony	21	end;
168
169	tony	27	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
170	tony	21	begin
171	tony	27	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
172			end;
173	tony	21
174	tony	27	{ TIBLookupComboDataLink }
175
176			procedure TIBLookupComboDataLink.ActiveChanged;
177			begin
178			FOwner.ActiveChanged(self)
179	tony	21	end;
180
181	tony	272	{$if lcl_fullversion < 2000003}
182	tony	209	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	tony	272	{$endif}
189	tony	209
190	tony	21	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	tony	27	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	tony	21	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	tony	27	IBControlLinkChanged;
241	tony	21	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	tony	27	var curKeyValue: variant;
283	tony	21	begin
284			if FFiltered then
285			begin
286			FFiltered := false;
287	tony	27	curKeyValue := KeyValue;
288			Text := ''; {Ensure full list}
289	tony	21	UpdateList;
290	tony	27	KeyValue := curKeyValue;
291	tony	21	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	tony	27	IBControlLinkChanged;
326	tony	21	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	tony	64	FCurText := Text;
342	tony	21	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	tony	64	Text := FCurText;
352			if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
353	tony	21	begin
354			if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
355			begin
356			sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
357	tony	64	if (sCompleteText <> FCurText) then
358	tony	21	begin
359	tony	225	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
360	tony	21	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	tony	225	SelLength := UTF8Length(Text) - iSelStart;
370	tony	21	end;
371	tony	65	end
372			else
373			begin
374			SelStart := iSelStart;
375			SelLength := 0;
376	tony	21	end;
377			end;
378			finally
379			FUpdating := false
380			end;
381	tony	143	FModified := true;
382	tony	21	end;
383			end;
384
385			procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
386			Parser: TSelectSQLParser);
387			var FieldPosition: integer;
388	tony	64	FilterText: string;
389	tony	21	begin
390			if FFiltered then
391			begin
392	tony	64	if FUpdating then
393			FilterText := FCurText
394			else
395			FilterText := Text;
396	tony	21	if cbactSearchCaseSensitive in AutoCompleteText then
397	tony	27	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
398	tony	272	SQLSafeString(FilterText) + '%''')
399	tony	21	else
400	tony	39	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
401	tony	272	SQLSafeString(FilterText) + '%'')');
402	tony	21
403	tony	41	if cbactSearchAscending in AutoCompleteText then
404			begin
405			FieldPosition := Parser.GetFieldPosition(ListField);
406			if FieldPosition = 0 then Exit;
407	tony	21
408	tony	41	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
409			end;
410	tony	21	end;
411			end;
412
413			procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
414			begin
415	tony	31	if AppDestroying in Application.Flags then Exit;
416	tony	27	SelectAll
417	tony	21	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	tony	35	if FInCheckAndInsert then Exit;
430			FInCheckAndInsert := true;
431	tony	21	try
432	tony	35	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	tony	21
447	tony	35	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	tony	21	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	tony	31	if FTimer.Interval <> 0 then
500			HandleTimer(nil);
501	tony	21	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	tony	225	if AutoComplete and (Style <> csDropDownList) then
524	tony	35	begin
525	tony	225	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	tony	35	FTimer.Interval := FKeyPressInterval;
540	tony	225	end;
541	tony	35	end;
542	tony	21	end;
543
544	tony	29	procedure TIBLookupComboEditBox.Loaded;
545			begin
546			inherited Loaded;
547			IBControlLinkChanged;
548			end;
549
550	tony	27	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	tony	21	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
559			begin
560	tony	225	if Val > 0 then
561			FCurText := '';
562	tony	21	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	tony	143	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
574			begin
575			inherited UpdateData(Sender);
576	tony	225	if FCurText <> '' then
577			Text := FCurText + Text;
578	tony	143	FModified := false;
579			end;
580
581	tony	275	{$if lcl_fullversion >= 2000002}
582	tony	263	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	tony	275	if DataSource = nil then
601	tony	272	THackedCustomComboBox(self).CallChange
602			else
603			inherited Change;
604	tony	263	end;
605
606			procedure TIBLookupComboEditBox.CloseUp;
607			begin
608	tony	272	inherited DoEdit;
609	tony	263	inherited CloseUp;
610	tony	272	EditingDone;
611	tony	263	end;
612
613			procedure TIBLookupComboEditBox.Select;
614			begin
615			inherited Select;
616	tony	275	if DataSource = nil then
617	tony	272	inherited DoEdit;
618	tony	263	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	tony	275	if DataSource = nil then
625	tony	263	Result := true
626			else
627			Result := inherited DoEdit;
628			end;
629			{$ifend}
630
631	tony	21	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
632			begin
633			inherited Create(TheComponent);
634			FDataLink := TIBLookupComboDataLink.Create(self);
635	tony	27	FIBLookupControlLink := TIBLookupControlLink.Create(self);
636			FKeyPressInterval := 200;
637	tony	21	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	tony	27	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
648	tony	21	if assigned(FTimer) then FTimer.Free;
649	tony	80	Application.RemoveAsyncCalls(self);
650	tony	21	inherited Destroy;
651			end;
652
653			procedure TIBLookupComboEditBox.EditingDone;
654			begin
655	tony	35	FForceAutoComplete := true;
656			try
657			if FTimer.Interval <> 0 then
658			HandleTimer(nil);
659			finally
660			FForceAutoComplete := false;
661			end;
662	tony	21	CheckAndInsert;
663	tony	225	FCurText := '';
664	tony	143	if FModified then
665			Change; {ensure Update}
666	tony	21	inherited EditingDone;
667			end;
668
669			end.