trunk/ibcontrols/IBLookupComboEditBox.pas

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

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
  ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;

type

  {TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
   of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
   to revise the available list and restrict it to items that are prefixed by the
   typed text (either case sensitive or case insenstive). Autoinsert allows a
   newly typed entry to be added to the list dataset and included in the available
   list items.    }

  TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
  TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;

  TIBLookupComboEditBox = class;

  { TIBLookupComboDataLink }

  TIBLookupComboDataLink = class(TDataLink)
  private
    FOwner: TIBLookupComboEditBox;
  protected
    procedure ActiveChanged; override;
    procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
    procedure RecordChanged(Field: TField); override;
    procedure UpdateData; override;
  public
    constructor Create(AOwner: TIBLookupComboEditBox);
  end;

  { TIBLookupControlLink }

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


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FIBLookupControlLink: TIBLookupControlLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: boolean;
    FLastKeyValue: variant;
    FCurText: string;
    FModified: boolean;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    {$if lcl_fullversion >= 2000000}
    {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;
    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;
    function SQLSafe(aText: string): string;
    procedure UpdateShowing; override;
    procedure UpdateData(Sender: TObject); override;
  public
    { Public declarations }
    constructor Create(TheComponent: TComponent); override;
    destructor Destroy; override;
    procedure EditingDone; override;
  published
    { Published declarations }
    property AutoInsert: boolean read FAutoInsert write FAutoInsert;
    property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
    property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
             write SetAutoCompleteText;
    property ItemHeight;
    property ItemWidth;
    property ListSource: TDataSource read GetListSource write SetListSource;
    property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
    property RelationName: string read FRelationName write FRelationName;
    property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
    property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
  end;


implementation

uses Variants, LCLProc, LazUTF8;

{ TIBLookupControlLink }

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

procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
begin
  FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
end;

{ TIBLookupComboDataLink }

procedure TIBLookupComboDataLink.ActiveChanged;
begin
  FOwner.ActiveChanged(self)
end;

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

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

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

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

{ TIBLookupComboEditBox }

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

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

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

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

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

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

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

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

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

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

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

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

procedure TIBLookupComboEditBox.UpdateList;
{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
  ListSource DataSet as the source for the autocomplete text. It also runs
  after a delay rather than immediately on keyup
}
var
  iSelStart: Integer; // char position
  sCompleteText, sPrefixText, sResultText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FCurText := Text;
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := FCurText;
         if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> FCurText) then
             begin
               KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
               sResultText := sCompleteText;
               if ((cbactEndOfLineComplete in AutoCompleteText) and
                         (cbactRetainPrefixCase in AutoCompleteText)) then
               begin//Retain Prefix Character cases
                 UTF8Delete(sResultText, 1, iSelStart);
                 UTF8Insert(sPrefixText, sResultText, 1);
               end;
               Text := sResultText;
               SelStart := iSelStart;
               SelLength := UTF8Length(Text) - iSelStart;
             end;
           end
           else
           begin
             SelStart := iSelStart;
             SelLength := 0;
           end;
         end;
    finally
      FUpdating := false
    end;
    FModified := true;
  end;
end;

procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
  Parser: TSelectSQLParser);
var FieldPosition: integer;
    FilterText: string;
begin
  if FFiltered then
  begin
    if FUpdating then
      FilterText := FCurText
    else
      FilterText := Text;
    if cbactSearchCaseSensitive in AutoCompleteText then
      Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
                                  SQLSafe(FilterText) + '%''')
    else
      Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' +  ListField + '") Like Upper(''' +
                                  SQLSafe(FilterText) + '%'')');

    if cbactSearchAscending in AutoCompleteText then
    begin
      FieldPosition := Parser.GetFieldPosition(ListField);
      if FieldPosition = 0 then Exit;

      Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
    end;
  end;
end;

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

procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
begin
  if FInserting then
    ListSource.DataSet.FieldByName(ListField).AsString := Text
end;

procedure TIBLookupComboEditBox.CheckAndInsert;
var Accept: boolean;
    NewKeyValue: variant;
begin
  if FInCheckAndInsert then Exit;
  FInCheckAndInsert := true;
  try
       if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
          and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
       try
         {Is it OK to insert a new list member?}
         Accept := true;
         if assigned(FOnCanAutoInsert) then
            OnCanAutoInsert(self,Text,Accept);
         if not Accept then
         begin
           ResetParser;
           Text := FOriginalTextValue;
           SelectAll;
           Exit;
         end;

         FInserting := true;
         try
           {New Value}
           FFiltered := false;
           if assigned(FOnAutoInsert) then
           begin
             {In an OnAutoInsert handler, the client is expected to insert the new
              row into the List DataSet and to set the KeyValue property to the
              value of the primary key of the new row.}
             OnAutoInsert(self,Text,NewKeyValue);
           end
           else
           begin
             ListSource.DataSet.Append;
             {The new KeyValue should be determined by an external generator or
              in the "OnInsert" handler. If it is the same as the ListField, then
              it will be set from the UpdateLinkData method}
             try
               ListSource.DataSet.Post;
             except
               ListSource.DataSet.Cancel;
               raise;
             end;
             NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           end;
           Text := ''; {Ensure full list}
           UpdateList;
           KeyValue := NewKeyValue;
           UpdateData(nil); {Force sync with DataField}
         finally
           FInserting := false
         end;
       except
         Text := FOriginalTextValue;
         ResetParser;
         raise;
       end;
  finally
    FInCheckAndInsert := false
  end;
end;

procedure TIBLookupComboEditBox.DoEnter;
begin
  inherited DoEnter;
  FOriginalTextValue:= Text;
  ResetParser;
  Application.QueueAsyncCall(@HandleEnter,0);
end;

procedure TIBLookupComboEditBox.DoExit;
begin
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  FExiting := true;
  try
    CheckAndInsert;
    ResetParser;
    FTimer.Interval := 0;
  finally
    FExiting := false;
  end;
  inherited DoExit;
end;

procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);
  if Key = VK_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  if AutoComplete and (Style <> csDropDownList) then
  begin
    if (Key = VK_BACK) or (Key = VK_DELETE) then
    begin
      if SelStart = 0 then
      begin
        SelStart := UTF8Length(Text);
        SelLength := 0;
      end;
      FTimer.Interval := 0;
    end
    else
    if IsEditableTextKey(Key) and
     (not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
    begin
      FTimer.Interval := 0;
      FTimer.Interval := FKeyPressInterval;
    end;
  end;
end;

procedure TIBLookupComboEditBox.Loaded;
begin
  inherited Loaded;
  IBControlLinkChanged;
end;

procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = DataSource) then
    ListSource := nil;
end;

procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
begin
  if Val > 0 then
    FCurText := '';
  inherited SetItemIndex(Val);
  FLastKeyValue := KeyValue;
end;

function TIBLookupComboEditBox.SQLSafe(aText: string): string;
var I: integer;
begin
  Result := '';
  for I := 1 to length(aText) do
    if aText[I] = '''' then
      Result := Result + ''''''
    else
      Result := Result + aText[I];
end;

procedure TIBLookupComboEditBox.UpdateShowing;
begin
  inherited UpdateShowing;
  if Showing then {Ensure up-to-date as we were ignoring any changes}
    ActiveChanged(nil);
end;

procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
begin
  inherited UpdateData(Sender);
  if FCurText <> '' then
    Text := FCurText + Text;
  FModified := false;
end;

{$if lcl_fullversion >= 2000000}
type

  { THackedCustomComboBox }

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

{ THackedCustomComboBox }

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

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
end;

procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
begin
  {TDBLookupComboBox.UTF8KeyPress will swallow the character if
  the datalink is not editable. hence to enable writing we must override it}
  if ((DataSource = nil) or (Field = nil)) and not ReadOnly then
    THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
  else
    inherited;
end;

procedure TIBLookupComboEditBox.Change;
begin
  THackedCustomComboBox(self).CallChange;
end;

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

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

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