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

# 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, 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 procedure RecordChanged(Field: TField); override;
58 procedure UpdateData; override;
59 public
60 constructor Create(AOwner: TIBLookupComboEditBox);
61 end;
62
63 { TIBLookupControlLink }
64
65 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 { TIBLookupComboEditBox }
76
77 TIBLookupComboEditBox = class(TDBLookupComboBox)
78 private
79 FCanAutoInsert: TCanAutoInsert;
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 procedure DoActiveChanged(Data: PtrInt);
100 function GetAutoCompleteText: TComboBoxAutoCompleteText;
101 function GetListSource: TDataSource;
102 function GetRelationNameQualifier: string;
103 procedure HandleTimer(Sender: TObject);
104 procedure IBControlLinkChanged;
105 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 procedure Loaded; override;
121 procedure Notification(AComponent: TComponent; Operation: TOperation); override;
122 procedure SetItemIndex(const Val: integer); override;
123 function SQLSafe(aText: string): string;
124 procedure UpdateShowing; override;
125
126 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 property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
141 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 uses IBQuery, LCLType, Variants, LCLProc, LazUTF8;
150
151 { TIBLookupControlLink }
152
153 constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
154 begin
155 inherited Create;
156 FOwner := AOwner;
157 end;
158
159 procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
160 begin
161 FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
162 end;
163
164 { TIBLookupComboDataLink }
165
166 procedure TIBLookupComboDataLink.ActiveChanged;
167 begin
168 FOwner.ActiveChanged(self)
169 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 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 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 IBControlLinkChanged;
223 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 var curKeyValue: variant;
265 begin
266 if FFiltered then
267 begin
268 FFiltered := false;
269 curKeyValue := KeyValue;
270 Text := ''; {Ensure full list}
271 UpdateList;
272 KeyValue := curKeyValue;
273 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 IBControlLinkChanged;
308 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 FCurText := Text;
324 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 Text := FCurText;
334 if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
335 begin
336 if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
337 begin
338 sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
339 if (sCompleteText <> FCurText) then
340 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 KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
353 end
354 else
355 begin
356 SelStart := iSelStart;
357 SelLength := 0;
358 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 FilterText: string;
370 begin
371 if FFiltered then
372 begin
373 if FUpdating then
374 FilterText := FCurText
375 else
376 FilterText := Text;
377 if cbactSearchCaseSensitive in AutoCompleteText then
378 Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
379 SQLSafe(FilterText) + '%''')
380 else
381 Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' + ListField + '") Like Upper(''' +
382 SQLSafe(FilterText) + '%'')');
383
384 if cbactSearchAscending in AutoCompleteText then
385 begin
386 FieldPosition := Parser.GetFieldPosition(ListField);
387 if FieldPosition = 0 then Exit;
388
389 Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
390 end;
391 end;
392 end;
393
394 procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
395 begin
396 if AppDestroying in Application.Flags then Exit;
397 SelectAll
398 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 if FInCheckAndInsert then Exit;
411 FInCheckAndInsert := true;
412 try
413 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
428 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 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 if FTimer.Interval <> 0 then
481 HandleTimer(nil);
482 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 begin
508 FTimer.Interval := 0;
509 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 end;
515
516 procedure TIBLookupComboEditBox.Loaded;
517 begin
518 inherited Loaded;
519 IBControlLinkChanged;
520 end;
521
522 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 procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
531 begin
532 inherited SetItemIndex(Val);
533 FLastKeyValue := KeyValue;
534 end;
535
536 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 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 FIBLookupControlLink := TIBLookupControlLink.Create(self);
559 FKeyPressInterval := 200;
560 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 if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
571 if assigned(FTimer) then FTimer.Free;
572 Application.RemoveAsyncCalls(self);
573 inherited Destroy;
574 end;
575
576 procedure TIBLookupComboEditBox.EditingDone;
577 begin
578 FForceAutoComplete := true;
579 try
580 if FTimer.Interval <> 0 then
581 HandleTimer(nil);
582 finally
583 FForceAutoComplete := false;
584 end;
585 CheckAndInsert;
586 inherited EditingDone;
587 end;
588
589 end.