ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 217
Committed: Fri Mar 16 10:27:26 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 17878 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, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34 ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet;
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 procedure DataEvent(Event: TDataEvent; Info: Ptrint); override;
58 procedure RecordChanged(Field: TField); override;
59 procedure UpdateData; override;
60 public
61 constructor Create(AOwner: TIBLookupComboEditBox);
62 end;
63
64 { TIBLookupControlLink }
65
66 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 { TIBLookupComboEditBox }
77
78 TIBLookupComboEditBox = class(TDBLookupComboBox)
79 private
80 { Private declarations }
81 FDataLink: TIBLookupComboDataLink;
82 FIBLookupControlLink: TIBLookupControlLink;
83 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 FForceAutoComplete: boolean;
96 FInCheckAndInsert: boolean;
97 FLastKeyValue: variant;
98 FCurText: string;
99 FModified: boolean;
100 procedure DoActiveChanged(Data: PtrInt);
101 function GetAutoCompleteText: TComboBoxAutoCompleteText;
102 function GetListSource: TDataSource;
103 function GetRelationNameQualifier: string;
104 procedure HandleTimer(Sender: TObject);
105 procedure IBControlLinkChanged;
106 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 procedure Loaded; override;
122 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
123 procedure SetItemIndex(const Val: integer); override;
124 function SQLSafe(aText: string): string;
125 procedure UpdateShowing; override;
126 procedure UpdateData(Sender: TObject); override;
127 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 property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
142 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 uses LCLType, Variants, LCLProc, LazUTF8;
151
152 { TIBLookupControlLink }
153
154 constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
155 begin
156 inherited Create;
157 FOwner := AOwner;
158 end;
159
160 procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
161 begin
162 FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
163 end;
164
165 { TIBLookupComboDataLink }
166
167 procedure TIBLookupComboDataLink.ActiveChanged;
168 begin
169 FOwner.ActiveChanged(self)
170 end;
171
172 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 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 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 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 IBControlLinkChanged;
230 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 var curKeyValue: variant;
272 begin
273 if FFiltered then
274 begin
275 FFiltered := false;
276 curKeyValue := KeyValue;
277 Text := ''; {Ensure full list}
278 UpdateList;
279 KeyValue := curKeyValue;
280 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 IBControlLinkChanged;
315 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 FCurText := Text;
331 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 Text := FCurText;
341 if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
342 begin
343 if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
344 begin
345 sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
346 if (sCompleteText <> FCurText) then
347 begin
348 sResultText := sCompleteText;
349 if ((cbactEndOfLineComplete in AutoCompleteText) and
350 (cbactRetainPrefixCase in AutoCompleteText)) then
351 begin//Retain Prefix Character cases
352 UTF8Delete(sResultText, 1, iSelStart);
353 UTF8Insert(sPrefixText, sResultText, 1);
354 end;
355 Text := sResultText;
356 SelStart := iSelStart;
357 SelLength := UTF8Length(Text);
358 end;
359 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
360 end
361 else
362 begin
363 SelStart := iSelStart;
364 SelLength := 0;
365 end;
366 end;
367 finally
368 FUpdating := false
369 end;
370 FModified := true;
371 end;
372 end;
373
374 procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
375 Parser: TSelectSQLParser);
376 var FieldPosition: integer;
377 FilterText: string;
378 begin
379 if FFiltered then
380 begin
381 if FUpdating then
382 FilterText := FCurText
383 else
384 FilterText := Text;
385 if cbactSearchCaseSensitive in AutoCompleteText then
386 Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
387 SQLSafe(FilterText) + '%''')
388 else
389 Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
390 SQLSafe(FilterText) + '%'')');
391
392 if cbactSearchAscending in AutoCompleteText then
393 begin
394 FieldPosition := Parser.GetFieldPosition(ListField);
395 if FieldPosition = 0 then Exit;
396
397 Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
398 end;
399 end;
400 end;
401
402 procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
403 begin
404 if AppDestroying in Application.Flags then Exit;
405 SelectAll
406 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 if FInCheckAndInsert then Exit;
419 FInCheckAndInsert := true;
420 try
421 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
436 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 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 if FTimer.Interval <> 0 then
489 HandleTimer(nil);
490 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 begin
516 FTimer.Interval := 0;
517 if (IsEditableTextKey(Key) or (Key = VK_BACK))
518 and AutoComplete and (Style <> csDropDownList) and
519 (not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
520 FTimer.Interval := FKeyPressInterval;
521 end;
522 end;
523
524 procedure TIBLookupComboEditBox.Loaded;
525 begin
526 inherited Loaded;
527 IBControlLinkChanged;
528 end;
529
530 procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
531 Operation: TOperation);
532 begin
533 inherited Notification(AComponent, Operation);
534 if (Operation = opRemove) and (AComponent = DataSource) then
535 ListSource := nil;
536 end;
537
538 procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
539 begin
540 inherited SetItemIndex(Val);
541 FLastKeyValue := KeyValue;
542 end;
543
544 function TIBLookupComboEditBox.SQLSafe(aText: string): string;
545 var I: integer;
546 begin
547 Result := '';
548 for I := 1 to length(aText) do
549 if aText[I] = '''' then
550 Result := Result + ''''''
551 else
552 Result := Result + aText[I];
553 end;
554
555 procedure TIBLookupComboEditBox.UpdateShowing;
556 begin
557 inherited UpdateShowing;
558 if Showing then {Ensure up-to-date as we were ignoring any changes}
559 ActiveChanged(nil);
560 end;
561
562 procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
563 begin
564 inherited UpdateData(Sender);
565 FModified := false;
566 end;
567
568 constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
569 begin
570 inherited Create(TheComponent);
571 FDataLink := TIBLookupComboDataLink.Create(self);
572 FIBLookupControlLink := TIBLookupControlLink.Create(self);
573 FKeyPressInterval := 200;
574 FAutoComplete := true;
575 FTimer := TTimer.Create(nil);
576 FTimer.Interval := 0;
577 FTimer.OnTimer := @HandleTimer;
578 FLastKeyValue := NULL;
579 end;
580
581 destructor TIBLookupComboEditBox.Destroy;
582 begin
583 if assigned(FDataLink) then FDataLink.Free;
584 if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
585 if assigned(FTimer) then FTimer.Free;
586 Application.RemoveAsyncCalls(self);
587 inherited Destroy;
588 end;
589
590 procedure TIBLookupComboEditBox.EditingDone;
591 begin
592 FForceAutoComplete := true;
593 try
594 if FTimer.Interval <> 0 then
595 HandleTimer(nil);
596 finally
597 FForceAutoComplete := false;
598 end;
599 CheckAndInsert;
600 if FModified then
601 Change; {ensure Update}
602 inherited EditingDone;
603 end;
604
605 end.