ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 225
Committed: Tue Apr 3 09:09:05 2018 UTC (5 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 18214 byte(s)
Log Message:
Fixes Merged

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