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 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;
    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;

  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.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;
  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;

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;
  inherited EditingDone;
end;

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