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