ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 39
Committed: Tue May 17 08:14:52 2016 UTC (7 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 17065 byte(s)
Log Message:
Committing updates for Release R1-4-1

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