ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 80
Committed: Mon Jan 1 11:31:07 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 17379 byte(s)
Log Message:
Fixes merged into public release

File Contents

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