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 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;
    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 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(GetRelationNameQualifier + 'Upper("' + 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 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;
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 (IsEditableTextKey(Key) or (Key = VK_BACK))
     and AutoComplete and (Style <> csDropDownList) and
     (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
    FTimer.Interval := FKeyPressInterval
  else
    FTimer.Interval := 0;
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
  CheckAndInsert;
  inherited EditingDone;
end;

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