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, 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
    FCanAutoInsert: TCanAutoInsert;
    { 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;
    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 IBQuery, LCLType, 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);
var ActiveState: boolean;
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
               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);
             end;
             KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
           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_RETURN then
     EditingDone
  else
  if Key = VK_ESCAPE then
  begin
    SelStart := UTF8Length(Text);      {Ensure end of line selection}
    ResetParser;
    Text := FOriginalTextValue;
    SelectAll;
  end
  else
  begin
    FTimer.Interval := 0;
    if (IsEditableTextKey(Key) or (Key = VK_BACK))
       and AutoComplete and (Style <> csDropDownList) and
       (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
      FTimer.Interval := FKeyPressInterval;
  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
  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);
  FModified := false;
end;

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;
  if FModified then
    Change; {ensure Update}
  inherited EditingDone;
end;

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