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;

type

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

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

  TIBLookupComboEditBox = class;

  { TIBLookupComboDataLink }

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

  { TIBLookupControlLink }

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


  { TIBLookupComboEditBox }

  TIBLookupComboEditBox = class(TDBLookupComboBox)
  private
    { Private declarations }
    FDataLink: TIBLookupComboDataLink;
    FIBLookupControlLink: TIBLookupControlLink;
    FAutoComplete: boolean;
    FAutoInsert: boolean;
    FKeyPressInterval: integer;
    FOnCanAutoInsert: TCanAutoInsert;
    FRelationName: string;
    FTimer: TTimer;
    FFiltered: boolean;
    FOnAutoInsert: TAutoInsert;
    FOriginalTextValue: string;
    FUpdating: boolean;
    FInserting: boolean;
    FExiting: boolean;
    FForceAutoComplete: boolean;
    FInCheckAndInsert: boolean;
    FLastKeyValue: variant;
    FCurText: string;
    FModified: boolean;
    procedure DoActiveChanged(Data: PtrInt);
    function GetAutoCompleteText: TComboBoxAutoCompleteText;
    function GetListSource: TDataSource;
    function GetRelationNameQualifier: string;
    procedure HandleTimer(Sender: TObject);
    procedure IBControlLinkChanged;
    procedure ResetParser;
    procedure RecordChanged(Sender: TObject; aField: TField);
    procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
    procedure SetListSource(AValue: TDataSource);
    procedure UpdateList;
    procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
    procedure HandleEnter(Data: PtrInt);
    procedure UpdateLinkData(Sender: TObject);
  protected
    { Protected declarations }
    procedure ActiveChanged(Sender: TObject);
    procedure CheckAndInsert;
    procedure DoEnter; override;
    procedure DoExit; override;
    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 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);
begin
  FTimer.Interval := 0;
  FFiltered := Text <> '';
  UpdateList
end;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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