ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 277
Committed: Mon Feb 4 13:45:30 2019 UTC (5 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 19850 byte(s)
Log Message:
Fixes merged

File Contents

# Content
1 (*
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 * The Original Code is (C) 2015 Tony Whyman, MWA Software
19 * (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, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34 ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35
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 {$if lcl_fullversion < 2000003}
58 procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
59 {$endif}
60 procedure RecordChanged(Field: TField); override;
61 procedure UpdateData; override;
62 public
63 constructor Create(AOwner: TIBLookupComboEditBox);
64 end;
65
66 { TIBLookupControlLink }
67
68 TIBLookupControlLink = class(TIBControlLink)
69 private
70 FOwner: TIBLookupComboEditBox;
71 protected
72 procedure UpdateSQL(Sender: TObject); override;
73 public
74 constructor Create(AOwner: TIBLookupComboEditBox);
75 end;
76
77
78 { TIBLookupComboEditBox }
79
80 TIBLookupComboEditBox = class(TDBLookupComboBox)
81 private
82 { Private declarations }
83 FDataLink: TIBLookupComboDataLink;
84 FIBLookupControlLink: TIBLookupControlLink;
85 FAutoComplete: boolean;
86 FAutoInsert: boolean;
87 FKeyPressInterval: integer;
88 FOnCanAutoInsert: TCanAutoInsert;
89 FRelationName: string;
90 FTimer: TTimer;
91 FFiltered: boolean;
92 FOnAutoInsert: TAutoInsert;
93 FOriginalTextValue: string;
94 FUpdating: boolean;
95 FInserting: boolean;
96 FExiting: boolean;
97 FForceAutoComplete: boolean;
98 FInCheckAndInsert: boolean;
99 FLastKeyValue: variant;
100 FCurText: string;
101 FModified: boolean;
102 procedure DoActiveChanged(Data: PtrInt);
103 function GetAutoCompleteText: TComboBoxAutoCompleteText;
104 function GetListSource: TDataSource;
105 function GetRelationNameQualifier: string;
106 procedure HandleTimer(Sender: TObject);
107 procedure IBControlLinkChanged;
108 procedure ResetParser;
109 procedure RecordChanged(Sender: TObject; aField: TField);
110 procedure SetAutoCompleteText(AValue: TComboBoxAutoCompleteText);
111 procedure SetListSource(AValue: TDataSource);
112 procedure UpdateList;
113 procedure UpdateSQL(Sender: TObject; Parser: TSelectSQLParser);
114 procedure HandleEnter(Data: PtrInt);
115 procedure UpdateLinkData(Sender: TObject);
116 protected
117 { Protected declarations }
118 procedure ActiveChanged(Sender: TObject);
119 procedure CheckAndInsert;
120 procedure DoEnter; override;
121 procedure DoExit; override;
122 {$if lcl_fullversion >= 2000002}
123 {Deferred update changes in Lazarus 2.0 stop the combo box working when
124 the datasource is nil. We thus have to reverse out the changes :(}
125 function DoEdit: boolean; override;
126 procedure Change; override;
127 procedure CloseUp; override;
128 procedure Select; override;
129 {$ifend}
130 {$if lcl_fullversion = 2000002}
131 procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
132 {$ifend}
133 procedure KeyUp(var Key: Word; Shift: TShiftState); override;
134 procedure Loaded; override;
135 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
136 procedure SetItemIndex(const Val: integer); override;
137 procedure UpdateShowing; override;
138 procedure UpdateData(Sender: TObject); override;
139 public
140 { Public declarations }
141 constructor Create(TheComponent: TComponent); override;
142 destructor Destroy; override;
143 procedure EditingDone; override;
144 published
145 { Published declarations }
146 property AutoInsert: boolean read FAutoInsert write FAutoInsert;
147 property AutoComplete: boolean read FAutoComplete write FAutoComplete default true;
148 property AutoCompleteText: TComboBoxAutoCompleteText read GetAutoCompleteText
149 write SetAutoCompleteText;
150 property ItemHeight;
151 property ItemWidth;
152 property ListSource: TDataSource read GetListSource write SetListSource;
153 property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
154 property RelationName: string read FRelationName write FRelationName;
155 property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
156 property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
157 end;
158
159
160 implementation
161
162 uses Variants, LCLProc, LazUTF8, IBUtils;
163
164 { TIBLookupControlLink }
165
166 constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
167 begin
168 inherited Create;
169 FOwner := AOwner;
170 end;
171
172 procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
173 begin
174 FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
175 end;
176
177 { TIBLookupComboDataLink }
178
179 procedure TIBLookupComboDataLink.ActiveChanged;
180 begin
181 FOwner.ActiveChanged(self)
182 end;
183
184 {$if lcl_fullversion < 2000003}
185 procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
186 begin
187 inherited DataEvent(Event, Info);
188 if Event = deLayoutChange then
189 FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
190 end;
191 {$endif}
192
193 procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
194 begin
195 FOwner.RecordChanged(self,Field);
196 end;
197
198 procedure TIBLookupComboDataLink.UpdateData;
199 begin
200 FOwner.UpdateLinkData(self)
201 end;
202
203 constructor TIBLookupComboDataLink.Create(AOwner: TIBLookupComboEditBox);
204 begin
205 inherited Create;
206 FOwner := AOwner
207 end;
208
209 { TIBLookupComboEditBox }
210
211 procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
212 begin
213 FTimer.Interval := 0;
214 FFiltered := Text <> '';
215 UpdateList
216 end;
217
218 procedure TIBLookupComboEditBox.IBControlLinkChanged;
219 begin
220 if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
221 FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
222 else
223 FIBLookupControlLink.IBDataSet := nil;
224 end;
225
226 function TIBLookupComboEditBox.GetListSource: TDataSource;
227 begin
228 Result := inherited ListSource;
229 end;
230
231 function TIBLookupComboEditBox.GetRelationNameQualifier: string;
232 begin
233 if FRelationName <> '' then
234 Result := FRelationName + '.'
235 else
236 Result := ''
237 end;
238
239 procedure TIBLookupComboEditBox.ActiveChanged(Sender: TObject);
240 begin
241 if not FInserting and not FUpdating then
242 Application.QueueAsyncCall(@DoActiveChanged,0);
243 IBControlLinkChanged;
244 end;
245
246 procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
247 begin
248 if AppDestroying in Application.Flags then Exit;
249
250 if (DataSource = nil) and assigned(ListSource) and assigned(ListSource.DataSet)
251 and ListSource.DataSet.Active then
252 begin
253 begin
254 if varIsNull(FLastKeyValue) and (ItemIndex = -1) then
255 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant
256 else
257 begin
258 KeyValue := FLastKeyValue;
259 UpdateData(self); {Force auto scroll}
260 if varIsNull(KeyValue) then {Value not present}
261 Text := ListSource.DataSet.FieldByName(ListField).AsString
262 end;
263 end;
264 end
265 else
266 if (DataSource <> nil) and assigned(DataSource.DataSet) and
267 (DataSource.DataSet.Active) and (DataField <> '') then
268 begin
269 ResetParser;
270 KeyValue := Field.AsVariant;
271 end
272 else
273 Text := '';
274 FOriginalTextValue := Text;
275 end;
276
277 function TIBLookupComboEditBox.GetAutoCompleteText: TComboBoxAutoCompleteText;
278 begin
279 Result := inherited AutoCompleteText;
280 if AutoComplete then
281 Result := Result + [cbactEnabled]
282 end;
283
284 procedure TIBLookupComboEditBox.ResetParser;
285 var curKeyValue: variant;
286 begin
287 if FFiltered then
288 begin
289 FFiltered := false;
290 curKeyValue := KeyValue;
291 Text := ''; {Ensure full list}
292 UpdateList;
293 KeyValue := curKeyValue;
294 UpdateData(self); {Force Scroll}
295 end;
296 end;
297
298 procedure TIBLookupComboEditBox.RecordChanged(Sender: TObject; aField: TField);
299 begin
300 {Make sure that we are in sync with other data controls}
301 if DataSource = nil then
302 begin
303 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
304 if VarIsNull(KeyValue) then {Probable deletion}
305 begin
306 UpdateList;
307 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
308 end;
309 end;
310 end;
311
312 procedure TIBLookupComboEditBox.SetAutoCompleteText(
313 AValue: TComboBoxAutoCompleteText);
314 begin
315 if AValue <> AutoCompleteText then
316 begin
317 FAutoComplete := cbactEnabled in AValue;
318 inherited AutoCompleteText := AValue - [cbactEnabled]
319 end;
320 end;
321
322 procedure TIBLookupComboEditBox.SetListSource(AValue: TDataSource);
323 begin
324 if AValue <> inherited ListSource then
325 begin
326 FDataLink.DataSource := AValue;
327 inherited ListSource := AValue;
328 IBControlLinkChanged;
329 end;
330 end;
331
332 procedure TIBLookupComboEditBox.UpdateList;
333 { Note: Algorithm taken from TCustomComboBox.KeyUp but modified to use the
334 ListSource DataSet as the source for the autocomplete text. It also runs
335 after a delay rather than immediately on keyup
336 }
337 var
338 iSelStart: Integer; // char position
339 sCompleteText, sPrefixText, sResultText: string;
340 begin
341 if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
342 and ListSource.DataSet.Active then
343 begin
344 FCurText := Text;
345 FUpdating := true;
346 try
347 iSelStart := SelStart;//Capture original cursor position
348 if ((iSelStart < UTF8Length(Text)) and
349 (cbactEndOfLineComplete in AutoCompleteText)) then
350 Exit;
351 sPrefixText := UTF8Copy(Text, 1, iSelStart);
352 ListSource.DataSet.Active := false;
353 ListSource.DataSet.Active := true;
354 Text := FCurText;
355 if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
356 begin
357 if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
358 begin
359 sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
360 if (sCompleteText <> FCurText) then
361 begin
362 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
363 sResultText := sCompleteText;
364 if ((cbactEndOfLineComplete in AutoCompleteText) and
365 (cbactRetainPrefixCase in AutoCompleteText)) then
366 begin//Retain Prefix Character cases
367 UTF8Delete(sResultText, 1, iSelStart);
368 UTF8Insert(sPrefixText, sResultText, 1);
369 end;
370 Text := sResultText;
371 SelStart := iSelStart;
372 SelLength := UTF8Length(Text) - iSelStart;
373 end;
374 end
375 else
376 begin
377 SelStart := iSelStart;
378 SelLength := 0;
379 end;
380 end;
381 finally
382 FUpdating := false
383 end;
384 FModified := true;
385 end;
386 end;
387
388 procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
389 Parser: TSelectSQLParser);
390 var FieldPosition: integer;
391 FilterText: string;
392 begin
393 if FFiltered then
394 begin
395 if FUpdating then
396 FilterText := FCurText
397 else
398 FilterText := Text;
399 if cbactSearchCaseSensitive in AutoCompleteText then
400 Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
401 SQLSafeString(FilterText) + '%''')
402 else
403 Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
404 SQLSafeString(FilterText) + '%'')');
405
406 if cbactSearchAscending in AutoCompleteText then
407 begin
408 FieldPosition := Parser.GetFieldPosition(ListField);
409 if FieldPosition = 0 then Exit;
410
411 Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
412 end;
413 end;
414 end;
415
416 procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
417 begin
418 if AppDestroying in Application.Flags then Exit;
419 SelectAll
420 end;
421
422 procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
423 begin
424 if FInserting then
425 ListSource.DataSet.FieldByName(ListField).AsString := Text
426 end;
427
428 procedure TIBLookupComboEditBox.CheckAndInsert;
429 var Accept: boolean;
430 NewKeyValue: variant;
431 begin
432 if FInCheckAndInsert then Exit;
433 FInCheckAndInsert := true;
434 try
435 if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
436 and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
437 try
438 {Is it OK to insert a new list member?}
439 Accept := true;
440 if assigned(FOnCanAutoInsert) then
441 OnCanAutoInsert(self,Text,Accept);
442 if not Accept then
443 begin
444 ResetParser;
445 Text := FOriginalTextValue;
446 SelectAll;
447 Exit;
448 end;
449
450 FInserting := true;
451 try
452 {New Value}
453 FFiltered := false;
454 if assigned(FOnAutoInsert) then
455 begin
456 {In an OnAutoInsert handler, the client is expected to insert the new
457 row into the List DataSet and to set the KeyValue property to the
458 value of the primary key of the new row.}
459 OnAutoInsert(self,Text,NewKeyValue);
460 end
461 else
462 begin
463 ListSource.DataSet.Append;
464 {The new KeyValue should be determined by an external generator or
465 in the "OnInsert" handler. If it is the same as the ListField, then
466 it will be set from the UpdateLinkData method}
467 try
468 ListSource.DataSet.Post;
469 except
470 ListSource.DataSet.Cancel;
471 raise;
472 end;
473 NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
474 end;
475 Text := ''; {Ensure full list}
476 UpdateList;
477 KeyValue := NewKeyValue;
478 UpdateData(nil); {Force sync with DataField}
479 finally
480 FInserting := false
481 end;
482 except
483 Text := FOriginalTextValue;
484 ResetParser;
485 raise;
486 end;
487 finally
488 FInCheckAndInsert := false
489 end;
490 end;
491
492 procedure TIBLookupComboEditBox.DoEnter;
493 begin
494 inherited DoEnter;
495 FOriginalTextValue:= Text;
496 ResetParser;
497 Application.QueueAsyncCall(@HandleEnter,0);
498 end;
499
500 procedure TIBLookupComboEditBox.DoExit;
501 begin
502 if FTimer.Interval <> 0 then
503 HandleTimer(nil);
504 FExiting := true;
505 try
506 CheckAndInsert;
507 ResetParser;
508 FTimer.Interval := 0;
509 finally
510 FExiting := false;
511 end;
512 inherited DoExit;
513 end;
514
515 procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
516 begin
517 inherited KeyUp(Key, Shift);
518 if Key = VK_ESCAPE then
519 begin
520 SelStart := UTF8Length(Text); {Ensure end of line selection}
521 ResetParser;
522 Text := FOriginalTextValue;
523 SelectAll;
524 end
525 else
526 if AutoComplete and (Style <> csDropDownList) then
527 begin
528 if (Key = VK_BACK) or (Key = VK_DELETE) then
529 begin
530 if SelStart = 0 then
531 begin
532 SelStart := UTF8Length(Text);
533 SelLength := 0;
534 end;
535 FTimer.Interval := 0;
536 end
537 else
538 if IsEditableTextKey(Key) and
539 (not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
540 begin
541 FTimer.Interval := 0;
542 FTimer.Interval := FKeyPressInterval;
543 end;
544 end;
545 end;
546
547 procedure TIBLookupComboEditBox.Loaded;
548 begin
549 inherited Loaded;
550 IBControlLinkChanged;
551 end;
552
553 procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
554 Operation: TOperation);
555 begin
556 inherited Notification(AComponent, Operation);
557 if (Operation = opRemove) and (AComponent = DataSource) then
558 ListSource := nil;
559 end;
560
561 procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
562 begin
563 if Val > 0 then
564 FCurText := '';
565 inherited SetItemIndex(Val);
566 FLastKeyValue := KeyValue;
567 end;
568
569 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 procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
577 begin
578 inherited UpdateData(Sender);
579 if FCurText <> '' then
580 Text := FCurText + Text;
581 FModified := false;
582 end;
583
584
585 {Workarounds due to bugs in various Lazarus 2.0 release candidates}
586 {$if lcl_fullversion >= 2000002}
587 type
588
589 { THackedCustomComboBox }
590
591 THackedCustomComboBox = class(TCustomComboBox)
592 private
593 procedure CallChange;
594 procedure CallUTF8KeyPress(var UTF8Key: TUTF8Char);
595 end;
596
597 { THackedCustomComboBox }
598
599 procedure THackedCustomComboBox.CallChange;
600 begin
601 inherited Change;
602 end;
603
604 procedure THackedCustomComboBox.CallUTF8KeyPress(var UTF8Key: TUTF8Char);
605 begin
606 inherited UTF8KeyPress(UTF8Key);
607 end;
608
609 procedure TIBLookupComboEditBox.Change;
610 begin
611 if DataSource = nil then
612 THackedCustomComboBox(self).CallChange
613 else
614 inherited Change;
615 end;
616
617 procedure TIBLookupComboEditBox.CloseUp;
618 begin
619 inherited DoEdit;
620 inherited CloseUp;
621 EditingDone;
622 end;
623
624 procedure TIBLookupComboEditBox.Select;
625 begin
626 inherited Select;
627 if DataSource = nil then
628 inherited DoEdit;
629 end;
630
631 function TIBLookupComboEditBox.DoEdit: boolean;
632 begin
633 {DoEdit will swallow characters if no editable Field. Hence, to enabled
634 writing we must avoid calling the inherited method.}
635 if DataSource = nil then
636 Result := true
637 else
638 Result := inherited DoEdit;
639 end;
640 {$ifend}
641
642 {$if lcl_fullversion = 2000002}
643 procedure TIBLookupComboEditBox.UTF8KeyPress(var UTF8Key: TUTF8Char);
644 begin
645 if DataSource = nil then
646 THackedCustomComboBox(self).CallUTF8KeyPress(UTF8Key)
647 else
648 inherited;
649 end;
650 {$ifend}
651
652
653 constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
654 begin
655 inherited Create(TheComponent);
656 FDataLink := TIBLookupComboDataLink.Create(self);
657 FIBLookupControlLink := TIBLookupControlLink.Create(self);
658 FKeyPressInterval := 200;
659 FAutoComplete := true;
660 FTimer := TTimer.Create(nil);
661 FTimer.Interval := 0;
662 FTimer.OnTimer := @HandleTimer;
663 FLastKeyValue := NULL;
664 end;
665
666 destructor TIBLookupComboEditBox.Destroy;
667 begin
668 if assigned(FDataLink) then FDataLink.Free;
669 if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
670 if assigned(FTimer) then FTimer.Free;
671 Application.RemoveAsyncCalls(self);
672 inherited Destroy;
673 end;
674
675 procedure TIBLookupComboEditBox.EditingDone;
676 begin
677 FForceAutoComplete := true;
678 try
679 if FTimer.Interval <> 0 then
680 HandleTimer(nil);
681 finally
682 FForceAutoComplete := false;
683 end;
684 CheckAndInsert;
685 FCurText := '';
686 if FModified then
687 Change; {ensure Update}
688 inherited EditingDone;
689 end;
690
691 end.