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

{ 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;
  curText: string;
begin
  if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
     and ListSource.DataSet.Active then
  begin
    FUpdating := true;
    try
         iSelStart := SelStart;//Capture original cursor position
         if ((iSelStart < UTF8Length(Text)) and
           (cbactEndOfLineComplete in AutoCompleteText)) then
                Exit;
         curText := Text;
         sPrefixText := UTF8Copy(Text, 1, iSelStart);
         ListSource.DataSet.Active := false;
         ListSource.DataSet.Active :=  true;
         Text := curText;
         if not FExiting and (FForceAutoComplete or Focused) and (Text <> '')then
         begin
           if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
           begin
             sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
             if (sCompleteText <> Text) 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;
         end;
    finally
      FUpdating := false
    end;
  end;
end;

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

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

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