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 < 2000000}
    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);
    procedure ValidateListField;
  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, IBMessages;

{ 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 < 2000000}
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
      ValidateListField;
      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;
    SQLDialect: integer;
begin
  if FFiltered then
  begin
    if FUpdating then
      FilterText := FCurText
    else
      FilterText := Text;

    if Parser.DataSet <> nil then
      SQLDialect := (Parser.DataSet as TIBCustomDataSet).Database.SQLDialect
    else
      SQLDialect := 1;

    if cbactSearchCaseSensitive in AutoCompleteText then
      Parser.Add2WhereClause(GetRelationNameQualifier + QuoteIdentifierIfNeeded(SQLDialect,ListField) + ' Like ''' +
                                  SQLSafeString(FilterText) + '%''')
    else
      Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + QuoteIdentifierIfNeeded(SQLDialect,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;

{Check to ensure that ListField exists and convert to upper case if necessary}

procedure TIBLookupComboEditBox.ValidateListField;
var SQLDialect: integer;
    FieldNames: TStringList;
begin
  if (ListSource = nil) or (ListSource.DataSet = nil) then Exit;
  SQLDialect := (ListSource.DataSet as TIBCustomDataSet).Database.SQLDialect;
  FieldNames := TStringList.Create;
  try
    FieldNames.CaseSensitive := true;
    FieldNames.Sorted := true;
    FieldNames.Duplicates := dupError;
    ListSource.DataSet.GetFieldNames(FieldNames);
    if FieldNames.IndexOf(ListField) = -1 then {not found}
    begin
      if (SQLDialect = 3) and (FieldNames.IndexOf(AnsiUpperCase(ListField)) <> - 1) then {normalise to upper case}
        ListField := AnsiUpperCase(ListField)
      else
        IBError(ibxeListFieldNotFound,[ListField])
    end;
  finally
    FieldNames.Free;
  end;
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:	291
Committed:	Fri Apr 17 10:26:08 2020 UTC (4 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	21026 byte(s)
Log Message:	Changed for 2.3.4 merged into public release
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26	unit IBLookupComboEditBox;
27
28	{$mode objfpc}{$H+}
29
30	interface
31
32	uses
33	Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35
36	type
37
38	{TIBLookupComboEditBox is a TDBLookupComboBox descendent that implements "autocomplete"
39	of typed in text and "autoinsert" of new entries. Autocomplete uses SQL manipulation
40	to revise the available list and restrict it to items that are prefixed by the
41	typed text (either case sensitive or case insenstive). Autoinsert allows a
42	newly typed entry to be added to the list dataset and included in the available
43	list items. }
44
45	TAutoInsert = procedure(Sender: TObject; aText: string; var NewKeyValue: variant) of object;
46	TCanAutoInsert = procedure (Sender: TObject; aText: string; var Accept: boolean) of object;
47
48	TIBLookupComboEditBox = class;
49
50	{ TIBLookupComboDataLink }
51
52	TIBLookupComboDataLink = class(TDataLink)
53	private
54	FOwner: TIBLookupComboEditBox;
55	protected
56	procedure ActiveChanged; override;
57	{$if lcl_fullversion < 2000000}
58	procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
59	{$endif}
60	procedure RecordChanged(Field: TField); override;
61	procedure UpdateData; override;
62	public
63	constructor Create(AOwner: TIBLookupComboEditBox);
64	end;
65
66	{ TIBLookupControlLink }
67
68	TIBLookupControlLink = class(TIBControlLink)
69	private
70	FOwner: TIBLookupComboEditBox;
71	protected
72	procedure UpdateSQL(Sender: TObject); override;
73	public
74	constructor Create(AOwner: TIBLookupComboEditBox);
75	end;
76
77
78	{ TIBLookupComboEditBox }
79
80	TIBLookupComboEditBox = class(TDBLookupComboBox)
81	private
82	{ Private declarations }
83	FDataLink: TIBLookupComboDataLink;
84	FIBLookupControlLink: TIBLookupControlLink;
85	FAutoComplete: boolean;
86	FAutoInsert: boolean;
87	FKeyPressInterval: integer;
88	FOnCanAutoInsert: TCanAutoInsert;
89	FRelationName: string;
90	FTimer: TTimer;
91	FFiltered: boolean;
92	FOnAutoInsert: TAutoInsert;
93	FOriginalTextValue: string;
94	FUpdating: boolean;
95	FInserting: boolean;
96	FExiting: boolean;
97	FForceAutoComplete: boolean;
98	FInCheckAndInsert: boolean;
99	FLastKeyValue: variant;
100	FCurText: string;
101	FModified: boolean;
102	procedure DoActiveChanged(Data: PtrInt);
103	function GetAutoCompleteText: TComboBoxAutoCompleteText;
104	function GetListSource: TDataSource;
105	function GetRelationNameQualifier: string;
106	procedure HandleTimer(Sender: TObject);
107	procedure IBControlLinkChanged;
108	procedure ResetParser;
109	procedure RecordChanged(Sender: TObject; aField: TField);
110	procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
111	procedure SetListSource(AValue: TDataSource);
112	procedure UpdateList;
113	procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
114	procedure HandleEnter(Data: PtrInt);
115	procedure UpdateLinkData(Sender: TObject);
116	procedure ValidateListField;
117	protected
118	{ Protected declarations }
119	procedure ActiveChanged(Sender: TObject);
120	procedure CheckAndInsert;
121	procedure DoEnter; override;
122	procedure DoExit; override;
123	{$if lcl_fullversion >= 2000002}
124	{Deferred update changes in Lazarus 2.0 stop the combo box working when
125	the datasource is nil. We thus have to reverse out the changes :(}
126	function DoEdit: boolean; override;
127	procedure Change; override;
128	procedure CloseUp; override;
129	procedure Select; override;
130	{$ifend}
131	{$if lcl_fullversion = 2000002}
132	procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
133	{$ifend}
134	procedure KeyUp(var Key: Word; Shift: TShiftState); override;
135	procedure Loaded; override;
136	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
137	procedure SetItemIndex(const Val: integer); override;
138	procedure UpdateShowing; override;
139	procedure UpdateData(Sender: TObject); override;
140	public
141	{ Public declarations }
142	constructor Create(TheComponent: TComponent); override;
143	destructor Destroy; override;
144	procedure EditingDone; override;
145	published
146	{ Published declarations }
147	property AutoInsert: boolean read FAutoInsert write FAutoInsert;
148	property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
149	property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
150	write SetAutoCompleteText;
151	property ItemHeight;
152	property ItemWidth;
153	property ListSource: TDataSource read GetListSource write SetListSource;
154	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
155	property RelationName: string read FRelationName write FRelationName;
156	property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
157	property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
158	end;
159
160
161	implementation
162
163	uses Variants, LCLProc, LazUTF8, IBUtils, IBMessages;
164
165	{ TIBLookupControlLink }
166
167	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
168	begin
169	inherited Create;
170	FOwner := AOwner;
171	end;
172
173	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
174	begin
175	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
176	end;
177
178	{ TIBLookupComboDataLink }
179
180	procedure TIBLookupComboDataLink.ActiveChanged;
181	begin
182	FOwner.ActiveChanged(self)
183	end;
184
185	{$if lcl_fullversion < 2000000}
186	procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
187	begin
188	inherited DataEvent(Event, Info);
189	if Event = deLayoutChange then
190	FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
191	end;
192	{$endif}
193
194	procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
195	begin
196	FOwner.RecordChanged(self,Field);
197	end;
198
199	procedure TIBLookupComboDataLink.UpdateData;
200	begin
201	FOwner.UpdateLinkData(self)
202	end;
203
204	constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
205	begin
206	inherited Create;
207	FOwner := AOwner
208	end;
209
210	{ TIBLookupComboEditBox }
211
212	procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
213	begin
214	FTimer.Interval := 0;
215	FFiltered := Text <> '';
216	UpdateList
217	end;
218
219	procedure TIBLookupComboEditBox.IBControlLinkChanged;
220	begin
221	if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
222	FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
223	else
224	FIBLookupControlLink.IBDataSet := nil;
225	end;
226
227	function TIBLookupComboEditBox.GetListSource: TDataSource;
228	begin
229	Result := inherited ListSource;
230	end;
231
232	function TIBLookupComboEditBox.GetRelationNameQualifier: string;
233	begin
234	if FRelationName <> '' then
235	Result := FRelationName + '.'
236	else
237	Result := ''
238	end;
239
240	procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
241	begin
242	if not FInserting and not FUpdating then
243	Application.QueueAsyncCall(@DoActiveChanged,0);
244	IBControlLinkChanged;
245	end;
246
247	procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
248	begin
249	if AppDestroying in Application.Flags then Exit;
250
251	if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
252	and ListSource.DataSet.Active then
253	begin
254	begin
255	ValidateListField;
256	if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
257	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
258	else
259	begin
260	KeyValue := FLastKeyValue;
261	UpdateData(self); {Force auto scroll}
262	if varIsNull(KeyValue) then {Value not present}
263	Text := ListSource.DataSet.FieldByName(ListField).AsString
264	end;
265	end;
266	end
267	else
268	if (DataSource <> nil) and assigned(DataSource.DataSet) and
269	(DataSource.DataSet.Active) and (DataField <> '') then
270	begin
271	ResetParser;
272	KeyValue := Field.AsVariant;
273	end
274	else
275	Text := '';
276	FOriginalTextValue := Text;
277	end;
278
279	function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
280	begin
281	Result := inherited AutoCompleteText;
282	if AutoComplete then
283	Result := Result + [cbactEnabled]
284	end;
285
286	procedure TIBLookupComboEditBox.ResetParser;
287	var curKeyValue: variant;
288	begin
289	if FFiltered then
290	begin
291	FFiltered := false;
292	curKeyValue := KeyValue;
293	Text := ''; {Ensure full list}
294	UpdateList;
295	KeyValue := curKeyValue;
296	UpdateData(self); {Force Scroll}
297	end;
298	end;
299
300	procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
301	begin
302	{Make sure that we are in sync with other data controls}
303	if DataSource = nil then
304	begin
305	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
306	if VarIsNull(KeyValue) then {Probable deletion}
307	begin
308	UpdateList;
309	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
310	end;
311	end;
312	end;
313
314	procedure TIBLookupComboEditBox.SetAutoCompleteText(
315	AValue: TComboBoxAutoCompleteText);
316	begin
317	if AValue <> AutoCompleteText then
318	begin
319	FAutoComplete := cbactEnabled in AValue;
320	inherited AutoCompleteText := AValue - [cbactEnabled]
321	end;
322	end;
323
324	procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
325	begin
326	if AValue <> inherited ListSource then
327	begin
328	FDataLink.DataSource := AValue;
329	inherited ListSource := AValue;
330	IBControlLinkChanged;
331	end;
332	end;
333
334	procedure TIBLookupComboEditBox.UpdateList;
335	{ Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
336	ListSource DataSet as the source for the autocomplete text. It also runs
337	after a delay rather than immediately on keyup
338	}
339	var
340	iSelStart: Integer; // char position
341	sCompleteText, sPrefixText, sResultText: string;
342	begin
343	if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
344	and ListSource.DataSet.Active then
345	begin
346	FCurText := Text;
347	FUpdating := true;
348	try
349	iSelStart := SelStart;//Capture original cursor position
350	if ((iSelStart < UTF8Length(Text)) and
351	(cbactEndOfLineComplete in AutoCompleteText)) then
352	Exit;
353	sPrefixText := UTF8Copy(Text, 1, iSelStart);
354	ListSource.DataSet.Active := false;
355	ListSource.DataSet.Active := true;
356	Text := FCurText;
357	if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
358	begin
359	if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
360	begin
361	sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
362	if (sCompleteText <> FCurText) then
363	begin
364	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
365	sResultText := sCompleteText;
366	if ((cbactEndOfLineComplete in AutoCompleteText) and
367	(cbactRetainPrefixCase in AutoCompleteText)) then
368	begin//Retain Prefix Character cases
369	UTF8Delete(sResultText, 1, iSelStart);
370	UTF8Insert(sPrefixText, sResultText, 1);
371	end;
372	Text := sResultText;
373	SelStart := iSelStart;
374	SelLength := UTF8Length(Text) - iSelStart;
375	end;
376	end
377	else
378	begin
379	SelStart := iSelStart;
380	SelLength := 0;
381	end;
382	end;
383	finally
384	FUpdating := false
385	end;
386	FModified := true;
387	end;
388	end;
389
390	procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
391	Parser: TSelectSQLParser);
392	var FieldPosition: integer;
393	FilterText: string;
394	SQLDialect: integer;
395	begin
396	if FFiltered then
397	begin
398	if FUpdating then
399	FilterText := FCurText
400	else
401	FilterText := Text;
402
403	if Parser.DataSet <> nil then
404	SQLDialect := (Parser.DataSet as TIBCustomDataSet).Database.SQLDialect
405	else
406	SQLDialect := 1;
407
408	if cbactSearchCaseSensitive in AutoCompleteText then
409	Parser.Add2WhereClause(GetRelationNameQualifier + QuoteIdentifierIfNeeded(SQLDialect,ListField) + ' Like ''' +
410	SQLSafeString(FilterText) + '%''')
411	else
412	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + QuoteIdentifierIfNeeded(SQLDialect,ListField) + ') Like Upper(''' +
413	SQLSafeString(FilterText) + '%'')');
414
415	if cbactSearchAscending in AutoCompleteText then
416	begin
417	FieldPosition := Parser.GetFieldPosition(ListField);
418	if FieldPosition = 0 then Exit;
419
420	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
421	end;
422	end;
423	end;
424
425	procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
426	begin
427	if AppDestroying in Application.Flags then Exit;
428	SelectAll
429	end;
430
431	procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
432	begin
433	if FInserting then
434	ListSource.DataSet.FieldByName(ListField).AsString := Text
435	end;
436
437	{Check to ensure that ListField exists and convert to upper case if necessary}
438
439	procedure TIBLookupComboEditBox.ValidateListField;
440	var SQLDialect: integer;
441	FieldNames: TStringList;
442	begin
443	if (ListSource = nil) or (ListSource.DataSet = nil) then Exit;
444	SQLDialect := (ListSource.DataSet as TIBCustomDataSet).Database.SQLDialect;
445	FieldNames := TStringList.Create;
446	try
447	FieldNames.CaseSensitive := true;
448	FieldNames.Sorted := true;
449	FieldNames.Duplicates := dupError;
450	ListSource.DataSet.GetFieldNames(FieldNames);
451	if FieldNames.IndexOf(ListField) = -1 then {not found}
452	begin
453	if (SQLDialect = 3) and (FieldNames.IndexOf(AnsiUpperCase(ListField)) <> - 1) then {normalise to upper case}
454	ListField := AnsiUpperCase(ListField)
455	else
456	IBError(ibxeListFieldNotFound,[ListField])
457	end;
458	finally
459	FieldNames.Free;
460	end;
461	end;
462
463	procedure TIBLookupComboEditBox.CheckAndInsert;
464	var Accept: boolean;
465	NewKeyValue: variant;
466	begin
467	if FInCheckAndInsert then Exit;
468	FInCheckAndInsert := true;
469	try
470	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
471	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
472	try
473	{Is it OK to insert a new list member?}
474	Accept := true;
475	if assigned(FOnCanAutoInsert) then
476	OnCanAutoInsert(self,Text,Accept);
477	if not Accept then
478	begin
479	ResetParser;
480	Text := FOriginalTextValue;
481	SelectAll;
482	Exit;
483	end;
484
485	FInserting := true;
486	try
487	{New Value}
488	FFiltered := false;
489	if assigned(FOnAutoInsert) then
490	begin
491	{In an OnAutoInsert handler, the client is expected to insert the new
492	row into the List DataSet and to set the KeyValue property to the
493	value of the primary key of the new row.}
494	OnAutoInsert(self,Text,NewKeyValue);
495	end
496	else
497	begin
498	ListSource.DataSet.Append;
499	{The new KeyValue should be determined by an external generator or
500	in the "OnInsert" handler. If it is the same as the ListField, then
501	it will be set from the UpdateLinkData method}
502	try
503	ListSource.DataSet.Post;
504	except
505	ListSource.DataSet.Cancel;
506	raise;
507	end;
508	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
509	end;
510	Text := ''; {Ensure full list}
511	UpdateList;
512	KeyValue := NewKeyValue;
513	UpdateData(nil); {Force sync with DataField}
514	finally
515	FInserting := false
516	end;
517	except
518	Text := FOriginalTextValue;
519	ResetParser;
520	raise;
521	end;
522	finally
523	FInCheckAndInsert := false
524	end;
525	end;
526
527	procedure TIBLookupComboEditBox.DoEnter;
528	begin
529	inherited DoEnter;
530	FOriginalTextValue:= Text;
531	ResetParser;
532	Application.QueueAsyncCall(@HandleEnter,0);
533	end;
534
535	procedure TIBLookupComboEditBox.DoExit;
536	begin
537	if FTimer.Interval <> 0 then
538	HandleTimer(nil);
539	FExiting := true;
540	try
541	CheckAndInsert;
542	ResetParser;
543	FTimer.Interval := 0;
544	finally
545	FExiting := false;
546	end;
547	inherited DoExit;
548	end;
549
550	procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
551	begin
552	inherited KeyUp(Key, Shift);
553	if Key = VK_ESCAPE then
554	begin
555	SelStart := UTF8Length(Text); {Ensure end of line selection}
556	ResetParser;
557	Text := FOriginalTextValue;
558	SelectAll;
559	end
560	else
561	if AutoComplete and (Style <> csDropDownList) then
562	begin
563	if (Key = VK_BACK) or (Key = VK_DELETE) then
564	begin
565	if SelStart = 0 then
566	begin
567	SelStart := UTF8Length(Text);
568	SelLength := 0;
569	end;
570	FTimer.Interval := 0;
571	end
572	else
573	if IsEditableTextKey(Key) and
574	(not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
575	begin
576	FTimer.Interval := 0;
577	FTimer.Interval := FKeyPressInterval;
578	end;
579	end;
580	end;
581
582	procedure TIBLookupComboEditBox.Loaded;
583	begin
584	inherited Loaded;
585	IBControlLinkChanged;
586	end;
587
588	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
589	Operation: TOperation);
590	begin
591	inherited Notification(AComponent, Operation);
592	if (Operation = opRemove) and (AComponent = DataSource) then
593	ListSource := nil;
594	end;
595
596	procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
597	begin
598	if Val > 0 then
599	FCurText := '';
600	inherited SetItemIndex(Val);
601	FLastKeyValue := KeyValue;
602	end;
603
604	procedure TIBLookupComboEditBox.UpdateShowing;
605	begin
606	inherited UpdateShowing;
607	if Showing then {Ensure up-to-date as we were ignoring any changes}
608	ActiveChanged(nil);
609	end;
610
611	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
612	begin
613	inherited UpdateData(Sender);
614	if FCurText <> '' then
615	Text := FCurText + Text;
616	FModified := false;
617	end;
618
619
620	{Workarounds due to bugs in various Lazarus 2.0 release candidates}
621	{$if lcl_fullversion >= 2000002}
622	type
623
624	{ THackedCustomComboBox }
625
626	THackedCustomComboBox = class(TCustomComboBox)
627	private
628	procedure CallChange;
629	procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
630	end;
631
632	{ THackedCustomComboBox }
633
634	procedure THackedCustomComboBox.CallChange;
635	begin
636	inherited Change;
637	end;
638
639	procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
640	begin
641	inherited UTF8KeyPress(UTF8Key);
642	end;
643
644	procedure TIBLookupComboEditBox.Change;
645	begin
646	if DataSource = nil then
647	THackedCustomComboBox(self).CallChange
648	else
649	inherited Change;
650	end;
651
652	procedure TIBLookupComboEditBox.CloseUp;
653	begin
654	inherited DoEdit;
655	inherited CloseUp;
656	EditingDone;
657	end;
658
659	procedure TIBLookupComboEditBox.Select;
660	begin
661	inherited Select;
662	if DataSource = nil then
663	inherited DoEdit;
664	end;
665
666	function TIBLookupComboEditBox.DoEdit: boolean;
667	begin
668	{DoEdit will swallow characters if no editable Field. Hence, to enabled
669	writing we must avoid calling the inherited method.}
670	if DataSource = nil then
671	Result := true
672	else
673	Result := inherited DoEdit;
674	end;
675	{$ifend}
676
677	{$if lcl_fullversion = 2000002}
678	procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
679	begin
680	if DataSource = nil then
681	THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
682	else
683	inherited;
684	end;
685	{$ifend}
686
687
688	constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
689	begin
690	inherited Create(TheComponent);
691	FDataLink := TIBLookupComboDataLink.Create(self);
692	FIBLookupControlLink := TIBLookupControlLink.Create(self);
693	FKeyPressInterval := 200;
694	FAutoComplete := true;
695	FTimer := TTimer.Create(nil);
696	FTimer.Interval := 0;
697	FTimer.OnTimer := @HandleTimer;
698	FLastKeyValue := NULL;
699	end;
700
701	destructor TIBLookupComboEditBox.Destroy;
702	begin
703	if assigned(FDataLink) then FDataLink.Free;
704	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
705	if assigned(FTimer) then FTimer.Free;
706	Application.RemoveAsyncCalls(self);
707	inherited Destroy;
708	end;
709
710	procedure TIBLookupComboEditBox.EditingDone;
711	begin
712	FForceAutoComplete := true;
713	try
714	if FTimer.Interval <> 0 then
715	HandleTimer(nil);
716	finally
717	FForceAutoComplete := false;
718	end;
719	CheckAndInsert;
720	FCurText := '';
721	if FModified then
722	Change; {ensure Update}
723	inherited EditingDone;
724	end;
725
726	end.