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;
    {$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 CallChange;
  end;

{ THackedCustomComboBox }

procedure THackedCustomComboBox.CallChange;
begin
  inherited Change;
end;

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

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

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

function TIBLookupComboEditBox.DoEdit: boolean;
begin
  {DoEdit will swallow characters if no editable Field. Hence, to enabled
   writing we must avoid calling the inherited method.}
  if IsUnbound then
    Result := true
  else
    Result := inherited DoEdit;
end;
{$ifend}

constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
begin
  inherited Create(TheComponent);
  FDataLink := TIBLookupComboDataLink.Create(self);
  FIBLookupControlLink := TIBLookupControlLink.Create(self);
  FKeyPressInterval := 200;
  FAutoComplete := true;
  FTimer := TTimer.Create(nil);
  FTimer.Interval := 0;
  FTimer.OnTimer := @HandleTimer;
  FLastKeyValue := NULL;
end;

destructor TIBLookupComboEditBox.Destroy;
begin
  if assigned(FDataLink) then FDataLink.Free;
  if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
  if assigned(FTimer) then FTimer.Free;
  Application.RemoveAsyncCalls(self);
  inherited Destroy;
end;

procedure TIBLookupComboEditBox.EditingDone;
begin
  FForceAutoComplete := true;
  try
  if FTimer.Interval <> 0 then
    HandleTimer(nil);
  finally
    FForceAutoComplete := false;
  end;
  CheckAndInsert;
  FCurText := '';
  if FModified then
    Change; {ensure Update}
  inherited EditingDone;
end;

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