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;
    {$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 TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  if DataSource = nil then
    THackedCustomComboBox(self).CallUTF8KeyPress(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:	277
Committed:	Mon Feb 4 13:45:30 2019 UTC (5 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	19850 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	276	{$if lcl_fullversion = 2000002}
131			procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
132			{$ifend}
133	tony	21	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
134	tony	29	procedure Loaded; override;
135	tony	27	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
136	tony	21	procedure SetItemIndex(const Val: integer); override;
137			procedure UpdateShowing; override;
138	tony	143	procedure UpdateData(Sender: TObject); override;
139	tony	21	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	tony	27	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
154	tony	21	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	tony	272	uses Variants, LCLProc, LazUTF8, IBUtils;
163	tony	21
164	tony	27	{ TIBLookupControlLink }
165	tony	21
166	tony	27	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
167	tony	21	begin
168	tony	27	inherited Create;
169			FOwner := AOwner;
170	tony	21	end;
171
172	tony	27	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
173	tony	21	begin
174	tony	27	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
175			end;
176	tony	21
177	tony	27	{ TIBLookupComboDataLink }
178
179			procedure TIBLookupComboDataLink.ActiveChanged;
180			begin
181			FOwner.ActiveChanged(self)
182	tony	21	end;
183
184	tony	272	{$if lcl_fullversion < 2000003}
185	tony	209	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	tony	272	{$endif}
192	tony	209
193	tony	21	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	tony	27	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	tony	21	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	tony	27	IBControlLinkChanged;
244	tony	21	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	tony	27	var curKeyValue: variant;
286	tony	21	begin
287			if FFiltered then
288			begin
289			FFiltered := false;
290	tony	27	curKeyValue := KeyValue;
291			Text := ''; {Ensure full list}
292	tony	21	UpdateList;
293	tony	27	KeyValue := curKeyValue;
294	tony	21	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	tony	27	IBControlLinkChanged;
329	tony	21	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	tony	64	FCurText := Text;
345	tony	21	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	tony	64	Text := FCurText;
355			if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
356	tony	21	begin
357			if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
358			begin
359			sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
360	tony	64	if (sCompleteText <> FCurText) then
361	tony	21	begin
362	tony	225	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
363	tony	21	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	tony	225	SelLength := UTF8Length(Text) - iSelStart;
373	tony	21	end;
374	tony	65	end
375			else
376			begin
377			SelStart := iSelStart;
378			SelLength := 0;
379	tony	21	end;
380			end;
381			finally
382			FUpdating := false
383			end;
384	tony	143	FModified := true;
385	tony	21	end;
386			end;
387
388			procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
389			Parser: TSelectSQLParser);
390			var FieldPosition: integer;
391	tony	64	FilterText: string;
392	tony	21	begin
393			if FFiltered then
394			begin
395	tony	64	if FUpdating then
396			FilterText := FCurText
397			else
398			FilterText := Text;
399	tony	21	if cbactSearchCaseSensitive in AutoCompleteText then
400	tony	27	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
401	tony	272	SQLSafeString(FilterText) + '%''')
402	tony	21	else
403	tony	39	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
404	tony	272	SQLSafeString(FilterText) + '%'')');
405	tony	21
406	tony	41	if cbactSearchAscending in AutoCompleteText then
407			begin
408			FieldPosition := Parser.GetFieldPosition(ListField);
409			if FieldPosition = 0 then Exit;
410	tony	21
411	tony	41	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
412			end;
413	tony	21	end;
414			end;
415
416			procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
417			begin
418	tony	31	if AppDestroying in Application.Flags then Exit;
419	tony	27	SelectAll
420	tony	21	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	tony	35	if FInCheckAndInsert then Exit;
433			FInCheckAndInsert := true;
434	tony	21	try
435	tony	35	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	tony	21
450	tony	35	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	tony	21	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	tony	31	if FTimer.Interval <> 0 then
503			HandleTimer(nil);
504	tony	21	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	tony	225	if AutoComplete and (Style <> csDropDownList) then
527	tony	35	begin
528	tony	225	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	tony	35	FTimer.Interval := FKeyPressInterval;
543	tony	225	end;
544	tony	35	end;
545	tony	21	end;
546
547	tony	29	procedure TIBLookupComboEditBox.Loaded;
548			begin
549			inherited Loaded;
550			IBControlLinkChanged;
551			end;
552
553	tony	27	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	tony	21	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
562			begin
563	tony	225	if Val > 0 then
564			FCurText := '';
565	tony	21	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	tony	143	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
577			begin
578			inherited UpdateData(Sender);
579	tony	225	if FCurText <> '' then
580			Text := FCurText + Text;
581	tony	143	FModified := false;
582			end;
583
584	tony	276
585			{Workarounds due to bugs in various Lazarus 2.0 release candidates}
586	tony	275	{$if lcl_fullversion >= 2000002}
587	tony	263	type
588
589			{ THackedCustomComboBox }
590
591			THackedCustomComboBox = class(TCustomComboBox)
592			private
593			procedure CallChange;
594	tony	276	procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
595	tony	263	end;
596
597			{ THackedCustomComboBox }
598
599			procedure THackedCustomComboBox.CallChange;
600			begin
601			inherited Change;
602			end;
603
604	tony	276	procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
605			begin
606			inherited UTF8KeyPress(UTF8Key);
607			end;
608
609	tony	263	procedure TIBLookupComboEditBox.Change;
610			begin
611	tony	275	if DataSource = nil then
612	tony	272	THackedCustomComboBox(self).CallChange
613			else
614			inherited Change;
615	tony	263	end;
616
617			procedure TIBLookupComboEditBox.CloseUp;
618			begin
619	tony	272	inherited DoEdit;
620	tony	263	inherited CloseUp;
621	tony	272	EditingDone;
622	tony	263	end;
623
624			procedure TIBLookupComboEditBox.Select;
625			begin
626			inherited Select;
627	tony	275	if DataSource = nil then
628	tony	272	inherited DoEdit;
629	tony	263	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	tony	275	if DataSource = nil then
636	tony	263	Result := true
637			else
638			Result := inherited DoEdit;
639			end;
640			{$ifend}
641
642	tony	276	{$if lcl_fullversion = 2000002}
643	tony	277	procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
644	tony	276	begin
645			if DataSource = nil then
646	tony	277	THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
647	tony	276	else
648			inherited;
649			end;
650			{$ifend}
651
652
653	tony	21	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
654			begin
655			inherited Create(TheComponent);
656			FDataLink := TIBLookupComboDataLink.Create(self);
657	tony	27	FIBLookupControlLink := TIBLookupControlLink.Create(self);
658			FKeyPressInterval := 200;
659	tony	21	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	tony	27	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
670	tony	21	if assigned(FTimer) then FTimer.Free;
671	tony	80	Application.RemoveAsyncCalls(self);
672	tony	21	inherited Destroy;
673			end;
674
675			procedure TIBLookupComboEditBox.EditingDone;
676			begin
677	tony	35	FForceAutoComplete := true;
678			try
679			if FTimer.Interval <> 0 then
680			HandleTimer(nil);
681			finally
682			FForceAutoComplete := false;
683			end;
684	tony	21	CheckAndInsert;
685	tony	225	FCurText := '';
686	tony	143	if FModified then
687			Change; {ensure Update}
688	tony	21	inherited EditingDone;
689			end;
690
691			end.