ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas
Revision: 29
Committed: Sat May 9 11:37:49 2015 UTC (8 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 16261 byte(s)
Log Message:
Committing updates for Release R1-2-4

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