ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 143
Committed: Fri Feb 23 12:11:21 2018 UTC (6 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 17653 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 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 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 41 uses IBQuery, 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     procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
173     begin
174     FOwner.RecordChanged(self,Field);
175     end;
176    
177     procedure TIBLookupComboDataLink.UpdateData;
178     begin
179     FOwner.UpdateLinkData(self)
180     end;
181    
182     constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
183     begin
184     inherited Create;
185     FOwner := AOwner
186     end;
187    
188     { TIBLookupComboEditBox }
189    
190     procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
191     var ActiveState: boolean;
192     begin
193     FTimer.Interval := 0;
194     FFiltered := Text <> '';
195     UpdateList
196     end;
197    
198 tony 27 procedure TIBLookupComboEditBox.IBControlLinkChanged;
199     begin
200     if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
201     FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
202     else
203     FIBLookupControlLink.IBDataSet := nil;
204     end;
205    
206 tony 21 function TIBLookupComboEditBox.GetListSource: TDataSource;
207     begin
208     Result := inherited ListSource;
209     end;
210    
211     function TIBLookupComboEditBox.GetRelationNameQualifier: string;
212     begin
213     if FRelationName <> '' then
214     Result := FRelationName + '.'
215     else
216     Result := ''
217     end;
218    
219     procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
220     begin
221     if not FInserting and not FUpdating then
222     Application.QueueAsyncCall(@DoActiveChanged,0);
223 tony 27 IBControlLinkChanged;
224 tony 21 end;
225    
226     procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
227     begin
228     if AppDestroying in Application.Flags then Exit;
229    
230     if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
231     and ListSource.DataSet.Active then
232     begin
233     begin
234     if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
235     KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
236     else
237     begin
238     KeyValue := FLastKeyValue;
239     UpdateData(self); {Force auto scroll}
240     if varIsNull(KeyValue) then {Value not present}
241     Text := ListSource.DataSet.FieldByName(ListField).AsString
242     end;
243     end;
244     end
245     else
246     if (DataSource <> nil) and assigned(DataSource.DataSet) and
247     (DataSource.DataSet.Active) and (DataField <> '') then
248     begin
249     ResetParser;
250     KeyValue := Field.AsVariant;
251     end
252     else
253     Text := '';
254     FOriginalTextValue := Text;
255     end;
256    
257     function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
258     begin
259     Result := inherited AutoCompleteText;
260     if AutoComplete then
261     Result := Result + [cbactEnabled]
262     end;
263    
264     procedure TIBLookupComboEditBox.ResetParser;
265 tony 27 var curKeyValue: variant;
266 tony 21 begin
267     if FFiltered then
268     begin
269     FFiltered := false;
270 tony 27 curKeyValue := KeyValue;
271     Text := ''; {Ensure full list}
272 tony 21 UpdateList;
273 tony 27 KeyValue := curKeyValue;
274 tony 21 UpdateData(self); {Force Scroll}
275     end;
276     end;
277    
278     procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
279     begin
280     {Make sure that we are in sync with other data controls}
281     if DataSource = nil then
282     begin
283     KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
284     if VarIsNull(KeyValue) then {Probable deletion}
285     begin
286     UpdateList;
287     KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
288     end;
289     end;
290     end;
291    
292     procedure TIBLookupComboEditBox.SetAutoCompleteText(
293     AValue: TComboBoxAutoCompleteText);
294     begin
295     if AValue <> AutoCompleteText then
296     begin
297     FAutoComplete := cbactEnabled in AValue;
298     inherited AutoCompleteText := AValue - [cbactEnabled]
299     end;
300     end;
301    
302     procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
303     begin
304     if AValue <> inherited ListSource then
305     begin
306     FDataLink.DataSource := AValue;
307     inherited ListSource := AValue;
308 tony 27 IBControlLinkChanged;
309 tony 21 end;
310     end;
311    
312     procedure TIBLookupComboEditBox.UpdateList;
313     { Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
314     ListSource DataSet as the source for the autocomplete text. It also runs
315     after a delay rather than immediately on keyup
316     }
317     var
318     iSelStart: Integer; // char position
319     sCompleteText, sPrefixText, sResultText: string;
320     begin
321     if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
322     and ListSource.DataSet.Active then
323     begin
324 tony 64 FCurText := Text;
325 tony 21 FUpdating := true;
326     try
327     iSelStart := SelStart;//Capture original cursor position
328     if ((iSelStart < UTF8Length(Text)) and
329     (cbactEndOfLineComplete in AutoCompleteText)) then
330     Exit;
331     sPrefixText := UTF8Copy(Text, 1, iSelStart);
332     ListSource.DataSet.Active := false;
333     ListSource.DataSet.Active := true;
334 tony 64 Text := FCurText;
335     if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
336 tony 21 begin
337     if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
338     begin
339     sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
340 tony 64 if (sCompleteText <> FCurText) then
341 tony 21 begin
342     sResultText := sCompleteText;
343     if ((cbactEndOfLineComplete in AutoCompleteText) and
344     (cbactRetainPrefixCase in AutoCompleteText)) then
345     begin//Retain Prefix Character cases
346     UTF8Delete(sResultText, 1, iSelStart);
347     UTF8Insert(sPrefixText, sResultText, 1);
348     end;
349     Text := sResultText;
350     SelStart := iSelStart;
351     SelLength := UTF8Length(Text);
352     end;
353 tony 31 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
354 tony 65 end
355     else
356     begin
357     SelStart := iSelStart;
358     SelLength := 0;
359 tony 21 end;
360     end;
361     finally
362     FUpdating := false
363     end;
364 tony 143 FModified := true;
365 tony 21 end;
366     end;
367    
368     procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
369     Parser: TSelectSQLParser);
370     var FieldPosition: integer;
371 tony 64 FilterText: string;
372 tony 21 begin
373     if FFiltered then
374     begin
375 tony 64 if FUpdating then
376     FilterText := FCurText
377     else
378     FilterText := Text;
379 tony 21 if cbactSearchCaseSensitive in AutoCompleteText then
380 tony 27 Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
381 tony 64 SQLSafe(FilterText) + '%''')
382 tony 21 else
383 tony 39 Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
384 tony 64 SQLSafe(FilterText) + '%'')');
385 tony 21
386 tony 41 if cbactSearchAscending in AutoCompleteText then
387     begin
388     FieldPosition := Parser.GetFieldPosition(ListField);
389     if FieldPosition = 0 then Exit;
390 tony 21
391 tony 41 Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
392     end;
393 tony 21 end;
394     end;
395    
396     procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
397     begin
398 tony 31 if AppDestroying in Application.Flags then Exit;
399 tony 27 SelectAll
400 tony 21 end;
401    
402     procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
403     begin
404     if FInserting then
405     ListSource.DataSet.FieldByName(ListField).AsString := Text
406     end;
407    
408     procedure TIBLookupComboEditBox.CheckAndInsert;
409     var Accept: boolean;
410     NewKeyValue: variant;
411     begin
412 tony 35 if FInCheckAndInsert then Exit;
413     FInCheckAndInsert := true;
414 tony 21 try
415 tony 35 if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
416     and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
417     try
418     {Is it OK to insert a new list member?}
419     Accept := true;
420     if assigned(FOnCanAutoInsert) then
421     OnCanAutoInsert(self,Text,Accept);
422     if not Accept then
423     begin
424     ResetParser;
425     Text := FOriginalTextValue;
426     SelectAll;
427     Exit;
428     end;
429 tony 21
430 tony 35 FInserting := true;
431     try
432     {New Value}
433     FFiltered := false;
434     if assigned(FOnAutoInsert) then
435     begin
436     {In an OnAutoInsert handler, the client is expected to insert the new
437     row into the List DataSet and to set the KeyValue property to the
438     value of the primary key of the new row.}
439     OnAutoInsert(self,Text,NewKeyValue);
440     end
441     else
442     begin
443     ListSource.DataSet.Append;
444     {The new KeyValue should be determined by an external generator or
445     in the "OnInsert" handler. If it is the same as the ListField, then
446     it will be set from the UpdateLinkData method}
447     try
448     ListSource.DataSet.Post;
449     except
450     ListSource.DataSet.Cancel;
451     raise;
452     end;
453     NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
454     end;
455     Text := ''; {Ensure full list}
456     UpdateList;
457     KeyValue := NewKeyValue;
458     UpdateData(nil); {Force sync with DataField}
459     finally
460     FInserting := false
461     end;
462     except
463     Text := FOriginalTextValue;
464     ResetParser;
465     raise;
466     end;
467     finally
468     FInCheckAndInsert := false
469 tony 21 end;
470     end;
471    
472     procedure TIBLookupComboEditBox.DoEnter;
473     begin
474     inherited DoEnter;
475     FOriginalTextValue:= Text;
476     ResetParser;
477     Application.QueueAsyncCall(@HandleEnter,0);
478     end;
479    
480     procedure TIBLookupComboEditBox.DoExit;
481     begin
482 tony 31 if FTimer.Interval <> 0 then
483     HandleTimer(nil);
484 tony 21 FExiting := true;
485     try
486     CheckAndInsert;
487     ResetParser;
488     FTimer.Interval := 0;
489     finally
490     FExiting := false;
491     end;
492     inherited DoExit;
493     end;
494    
495     procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
496     begin
497     inherited KeyUp(Key, Shift);
498     if Key = VK_RETURN then
499     EditingDone
500     else
501     if Key = VK_ESCAPE then
502     begin
503     SelStart := UTF8Length(Text); {Ensure end of line selection}
504     ResetParser;
505     Text := FOriginalTextValue;
506     SelectAll;
507     end
508     else
509 tony 35 begin
510 tony 29 FTimer.Interval := 0;
511 tony 35 if (IsEditableTextKey(Key) or (Key = VK_BACK))
512     and AutoComplete and (Style <> csDropDownList) and
513     (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
514     FTimer.Interval := FKeyPressInterval;
515     end;
516 tony 21 end;
517    
518 tony 29 procedure TIBLookupComboEditBox.Loaded;
519     begin
520     inherited Loaded;
521     IBControlLinkChanged;
522     end;
523    
524 tony 27 procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
525     Operation: TOperation);
526     begin
527     inherited Notification(AComponent, Operation);
528     if (Operation = opRemove) and (AComponent = DataSource) then
529     ListSource := nil;
530     end;
531    
532 tony 21 procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
533     begin
534     inherited SetItemIndex(Val);
535     FLastKeyValue := KeyValue;
536     end;
537    
538 tony 27 function TIBLookupComboEditBox.SQLSafe(aText: string): string;
539     var I: integer;
540     begin
541     Result := '';
542     for I := 1 to length(aText) do
543     if aText[I] = '''' then
544     Result := Result + ''''''
545     else
546     Result := Result + aText[I];
547     end;
548    
549 tony 21 procedure TIBLookupComboEditBox.UpdateShowing;
550     begin
551     inherited UpdateShowing;
552     if Showing then {Ensure up-to-date as we were ignoring any changes}
553     ActiveChanged(nil);
554     end;
555    
556 tony 143 procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
557     begin
558     inherited UpdateData(Sender);
559     FModified := false;
560     end;
561    
562 tony 21 constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
563     begin
564     inherited Create(TheComponent);
565     FDataLink := TIBLookupComboDataLink.Create(self);
566 tony 27 FIBLookupControlLink := TIBLookupControlLink.Create(self);
567     FKeyPressInterval := 200;
568 tony 21 FAutoComplete := true;
569     FTimer := TTimer.Create(nil);
570     FTimer.Interval := 0;
571     FTimer.OnTimer := @HandleTimer;
572     FLastKeyValue := NULL;
573     end;
574    
575     destructor TIBLookupComboEditBox.Destroy;
576     begin
577     if assigned(FDataLink) then FDataLink.Free;
578 tony 27 if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
579 tony 21 if assigned(FTimer) then FTimer.Free;
580 tony 80 Application.RemoveAsyncCalls(self);
581 tony 21 inherited Destroy;
582     end;
583    
584     procedure TIBLookupComboEditBox.EditingDone;
585     begin
586 tony 35 FForceAutoComplete := true;
587     try
588     if FTimer.Interval <> 0 then
589     HandleTimer(nil);
590     finally
591     FForceAutoComplete := false;
592     end;
593 tony 21 CheckAndInsert;
594 tony 143 if FModified then
595     Change; {ensure Update}
596 tony 21 inherited EditingDone;
597     end;
598    
599     end.