ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/ibcontrols/IBLookupComboEditBox.pas

Comparing ibx/trunk/ibcontrols/IBLookupComboEditBox.pas (file contents):
Revision 21 by tony, Thu Feb 26 10:33:34 2015 UTC vs.
Revision 268 by tony, Fri Dec 28 11:36:35 2018 UTC

#	Line 15 | Line 15
15		*
16		*  The Initial Developer of the Original Code is Tony Whyman.
17		*
18	<	*  The Original Code is (C) 2011 Tony Whyman, MWA Software
18	>	*  The Original Code is (C) 2015 Tony Whyman, MWA Software
19		*  (http://www.mwasoftware.co.uk).
20		*
21		*  All Rights Reserved.
#	Line 30 | Line 30 | unit IBLookupComboEditBox;
30		interface
31
32		uses
33	<	Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	<	ExtCtrls, IBSQLParser, DB, StdCtrls;
33	>	Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs, DbCtrls,
34	>	ExtCtrls, IBSQLParser, DB, StdCtrls, IBCustomDataSet, LCLVersion;
35
36		type
37
#	Line 61 | Line 61 | type
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
69	–	FCanAutoInsert: TCanAutoInsert;
80		{ Private declarations }
81		FDataLink: TIBLookupComboDataLink;
82	+	FIBLookupControlLink: TIBLookupControlLink;
83		FAutoComplete: boolean;
84		FAutoInsert: boolean;
85		FKeyPressInterval: integer;
#	Line 81 | Line 92 | type
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);
#	Line 101 | Line 117 | type
117		procedure CheckAndInsert;
118		procedure DoEnter; override;
119		procedure DoExit; override;
120	+	{$if lcl_fullversion >= 2000003}
121	+	{Deferred update changes in Lazarus 2.0 stop the combo box working when
122	+	the datasource is nil. We thus have to reverse out the changes :(}
123	+	function DoEdit: boolean; override;
124	+	procedure Change; override;
125	+	procedure CloseUp; override;
126	+	procedure Select; override;
127	+	{$ifend}
128		procedure KeyUp(var Key: Word; Shift: TShiftState); override;
129	+	procedure Loaded; override;
130	+	procedure Notification(AComponent: TComponent; Operation: TOperation); override;
131		procedure SetItemIndex(const Val: integer); override;
132	+	function SQLSafe(aText: string): string;
133		procedure UpdateShowing; override;
134	+	procedure UpdateData(Sender: TObject); override;
135		public
136		{ Public declarations }
137		constructor Create(TheComponent: TComponent); override;
#	Line 118 | Line 146 | type
146		property ItemHeight;
147		property ItemWidth;
148		property ListSource: TDataSource read GetListSource write SetListSource;
149	<	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 500;
149	>	property KeyPressInterval: integer read FKeyPressInterval write FKeyPressInterval default 200;
150		property RelationName: string read FRelationName write FRelationName;
151		property OnAutoInsert: TAutoInsert read FOnAutoInsert write FOnAutoInsert;
152		property OnCanAutoInsert: TCanAutoInsert read FOnCanAutoInsert write FOnCanAutoInsert;
#	Line 127 | Line 155 | type
155
156		implementation
157
158	<	uses IBQuery, IBCustomDataSet, LCLType, Variants, LCLProc;
158	>	uses Variants, LCLProc, LazUTF8;
159	>
160	>	{ TIBLookupControlLink }
161	>
162	>	constructor TIBLookupControlLink.Create(AOwner: TIBLookupComboEditBox);
163	>	begin
164	>	inherited Create;
165	>	FOwner := AOwner;
166	>	end;
167	>
168	>	procedure TIBLookupControlLink.UpdateSQL(Sender: TObject);
169	>	begin
170	>	FOwner.UpdateSQL(self,TIBParserDataSet(Sender).Parser)
171	>	end;
172
173		{ TIBLookupComboDataLink }
174
#	Line 138 | Line 179 | end;
179
180		procedure TIBLookupComboDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
181		begin
182	<	{If we are not visible then avoid unnecessary work}
183	<	if not FOwner.Showing then Exit;
184	<
144	<	if (Event = deCheckBrowseMode) and (Info = 1) and not DataSet.Active then
145	<	begin
146	<	if (DataSet is TIBDataSet) then
147	<	FOwner.UpdateSQL(self,TIBDataSet(DataSet).Parser)
148	<	else
149	<	if (DataSet is TIBQuery) then
150	<	FOwner.UpdateSQL(self,TIBQuery(DataSet).Parser)
151	<	end
152	<	else
153	<	inherited DataEvent(Event, Info);
182	>	inherited DataEvent(Event, Info);
183	>	if Event = deLayoutChange then
184	>	FOwner.LookupCache := FOwner.LookupCache; {sneaky way of calling UpdateLookup}
185		end;
186
187		procedure TIBLookupComboDataLink.RecordChanged(Field: TField);
#	Line 172 | Line 203 | end;
203		{ TIBLookupComboEditBox }
204
205		procedure TIBLookupComboEditBox.HandleTimer(Sender: TObject);
175	–	var ActiveState: boolean;
206		begin
207		FTimer.Interval := 0;
208		FFiltered := Text <> '';
209		UpdateList
210		end;
211
212	+	procedure TIBLookupComboEditBox.IBControlLinkChanged;
213	+	begin
214	+	if (ListSource <> nil) and (ListSource.DataSet <> nil) and (ListSource.DataSet is TIBParserDataSet) then
215	+	FIBLookupControlLink.IBDataSet := TIBCustomDataSet(ListSource.DataSet)
216	+	else
217	+	FIBLookupControlLink.IBDataSet := nil;
218	+	end;
219	+
220		function TIBLookupComboEditBox.GetListSource: TDataSource;
221		begin
222		Result := inherited ListSource;
#	Line 196 | Line 234 | procedure TIBLookupComboEditBox.ActiveCh
234		begin
235		if not FInserting and not FUpdating then
236		Application.QueueAsyncCall(@DoActiveChanged,0);
237	+	IBControlLinkChanged;
238		end;
239
240		procedure TIBLookupComboEditBox.DoActiveChanged(Data: PtrInt);
#	Line 237 | Line 276 | begin
276		end;
277
278		procedure TIBLookupComboEditBox.ResetParser;
279	+	var curKeyValue: variant;
280		begin
281		if FFiltered then
282		begin
283		FFiltered := false;
284	+	curKeyValue := KeyValue;
285	+	Text := ''; {Ensure full list}
286		UpdateList;
287	+	KeyValue := curKeyValue;
288		UpdateData(self); {Force Scroll}
289		end;
290		end;
#	Line 276 | Line 319 | begin
319		begin
320		FDataLink.DataSource := AValue;
321		inherited ListSource := AValue;
322	+	IBControlLinkChanged;
323		end;
324		end;
325
#	Line 287 | Line 331 | procedure TIBLookupComboEditBox.UpdateLi
331		var
332		iSelStart: Integer; // char position
333		sCompleteText, sPrefixText, sResultText: string;
290	–	curText: string;
334		begin
335		if assigned(ListSource) and assigned(ListSource.DataSet) and (ListSource.DataSet is TIBCustomDataSet)
336		and ListSource.DataSet.Active then
337		begin
338	+	FCurText := Text;
339		FUpdating := true;
340		try
341		iSelStart := SelStart;//Capture original cursor position
342		if ((iSelStart < UTF8Length(Text)) and
343		(cbactEndOfLineComplete in AutoCompleteText)) then
344		Exit;
301	–	curText := Text;
345		sPrefixText := UTF8Copy(Text, 1, iSelStart);
346		ListSource.DataSet.Active := false;
347		ListSource.DataSet.Active :=  true;
348	<	Text := curText;
349	<	if not FExiting and Focused and (Text <> '')then
348	>	Text := FCurText;
349	>	if not FExiting and (FForceAutoComplete or Focused) and (FCurText <> '')then
350		begin
351		if ListSource.DataSet.Active and (ListSource.DataSet.RecordCount > 0) then
352		begin
353		sCompleteText := ListSource.DataSet.FieldByName(ListField).AsString;
354	<	if (sCompleteText <> Text) then
354	>	if (sCompleteText <> FCurText) then
355		begin
356	+	KeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
357		sResultText := sCompleteText;
358		if ((cbactEndOfLineComplete in AutoCompleteText) and
359		(cbactRetainPrefixCase in AutoCompleteText)) then
#	Line 319 | Line 363 | begin
363		end;
364		Text := sResultText;
365		SelStart := iSelStart;
366	<	SelLength := UTF8Length(Text);
366	>	SelLength := UTF8Length(Text) - iSelStart;
367		end;
368	+	end
369	+	else
370	+	begin
371	+	SelStart := iSelStart;
372	+	SelLength := 0;
373		end;
374		end;
375		finally
376		FUpdating := false
377		end;
378	+	FModified := true;
379		end;
380		end;
381
382		procedure TIBLookupComboEditBox.UpdateSQL(Sender: TObject;
383		Parser: TSelectSQLParser);
384		var FieldPosition: integer;
385	+	FilterText: string;
386		begin
387		if FFiltered then
388		begin
389	+	if FUpdating then
390	+	FilterText := FCurText
391	+	else
392	+	FilterText := Text;
393		if cbactSearchCaseSensitive in AutoCompleteText then
394	<	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' + Text + '%''')
394	>	Parser.Add2WhereClause(GetRelationNameQualifier + '"' + ListField + '" Like ''' +
395	>	SQLSafe(FilterText) + '%''')
396		else
397	<	Parser.Add2WhereClause(GetRelationNameQualifier + 'Upper("' + ListField + '") Like Upper(''' + Text + '%'')');
397	>	Parser.Add2WhereClause('Upper(' + GetRelationNameQualifier + '"' +  ListField + '") Like Upper(''' +
398	>	SQLSafe(FilterText) + '%'')');
399
400	<	end;
401	<	if cbactSearchAscending in AutoCompleteText then
402	<	begin
403	<	FieldPosition := Parser.GetFieldPosition(ListField);
347	<	if FieldPosition = 0 then Exit;
400	>	if cbactSearchAscending in AutoCompleteText then
401	>	begin
402	>	FieldPosition := Parser.GetFieldPosition(ListField);
403	>	if FieldPosition = 0 then Exit;
404
405	<	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
405	>	Parser.OrderByClause := IntToStr(FieldPosition) + ' ascending';
406	>	end;
407		end;
408		end;
409
410		procedure TIBLookupComboEditBox.HandleEnter(Data: PtrInt);
411		begin
412	<	SelectAll
412	>	if AppDestroying in Application.Flags then Exit;
413	>	SelectAll
414		end;
415
416		procedure TIBLookupComboEditBox.UpdateLinkData(Sender: TObject);
#	Line 365 | Line 423 | procedure TIBLookupComboEditBox.CheckAnd
423		var Accept: boolean;
424		NewKeyValue: variant;
425		begin
426	<	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
427	<	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
426	>	if FInCheckAndInsert then Exit;
427	>	FInCheckAndInsert := true;
428		try
429	<	{Is it OK to insert a new list member?}
430	<	Accept := true;
431	<	if assigned(FOnCanAutoInsert) then
432	<	OnCanAutoInsert(self,Text,Accept);
433	<	if not Accept then
434	<	begin
435	<	ResetParser;
436	<	Text := FOriginalTextValue;
437	<	SelectAll;
438	<	Exit;
439	<	end;
429	>	if AutoInsert and (Text <> '') and assigned(ListSource) and assigned(ListSource.DataSet)
430	>	and ListSource.DataSet.Active and (ListSource.DataSet.RecordCount = 0) then
431	>	try
432	>	{Is it OK to insert a new list member?}
433	>	Accept := true;
434	>	if assigned(FOnCanAutoInsert) then
435	>	OnCanAutoInsert(self,Text,Accept);
436	>	if not Accept then
437	>	begin
438	>	ResetParser;
439	>	Text := FOriginalTextValue;
440	>	SelectAll;
441	>	Exit;
442	>	end;
443
444	<	FInserting := true;
445	<	try
446	<	{New Value}
447	<	FFiltered := false;
448	<	if assigned(FOnAutoInsert) then
449	<	begin
450	<	{In an OnAutoInsert handler, the client is expected to insert the new
451	<	row into the List DataSet and to set the KeyValue property to the
452	<	value of the primary key of the new row.}
453	<	OnAutoInsert(self,Text,NewKeyValue);
454	<	end
455	<	else
456	<	begin
457	<	ListSource.DataSet.Append;
458	<	{The new KeyValue should be determined by an external generator or
459	<	in the "OnInsert" handler. If it is the same as the ListField, then
460	<	it will be set from the UpdateLinkData method}
461	<	try
462	<	ListSource.DataSet.Post;
463	<	except
464	<	ListSource.DataSet.Cancel;
465	<	raise;
466	<	end;
467	<	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
468	<	end;
469	<	UpdateList;
470	<	KeyValue := NewKeyValue;
471	<	UpdateData(nil); {Force sync with DataField}
472	<	finally
473	<	FInserting := false
474	<	end;
475	<	except
476	<	Text := FOriginalTextValue;
477	<	ResetParser;
478	<	raise;
444	>	FInserting := true;
445	>	try
446	>	{New Value}
447	>	FFiltered := false;
448	>	if assigned(FOnAutoInsert) then
449	>	begin
450	>	{In an OnAutoInsert handler, the client is expected to insert the new
451	>	row into the List DataSet and to set the KeyValue property to the
452	>	value of the primary key of the new row.}
453	>	OnAutoInsert(self,Text,NewKeyValue);
454	>	end
455	>	else
456	>	begin
457	>	ListSource.DataSet.Append;
458	>	{The new KeyValue should be determined by an external generator or
459	>	in the "OnInsert" handler. If it is the same as the ListField, then
460	>	it will be set from the UpdateLinkData method}
461	>	try
462	>	ListSource.DataSet.Post;
463	>	except
464	>	ListSource.DataSet.Cancel;
465	>	raise;
466	>	end;
467	>	NewKeyValue := ListSource.DataSet.FieldByName(KeyField).AsVariant;
468	>	end;
469	>	Text := ''; {Ensure full list}
470	>	UpdateList;
471	>	KeyValue := NewKeyValue;
472	>	UpdateData(nil); {Force sync with DataField}
473	>	finally
474	>	FInserting := false
475	>	end;
476	>	except
477	>	Text := FOriginalTextValue;
478	>	ResetParser;
479	>	raise;
480	>	end;
481	>	finally
482	>	FInCheckAndInsert := false
483		end;
484		end;
485
#	Line 428 | Line 493 | end;
493
494		procedure TIBLookupComboEditBox.DoExit;
495		begin
496	+	if FTimer.Interval <> 0 then
497	+	HandleTimer(nil);
498		FExiting := true;
499		try
500		CheckAndInsert;
#	Line 442 | Line 509 | end;
509		procedure TIBLookupComboEditBox.KeyUp(var Key: Word; Shift: TShiftState);
510		begin
511		inherited KeyUp(Key, Shift);
445	–	if Key = VK_RETURN then
446	–	EditingDone
447	–	else
512		if Key = VK_ESCAPE then
513		begin
514		SelStart := UTF8Length(Text);      {Ensure end of line selection}
#	Line 453 | Line 517 | begin
517		SelectAll;
518		end
519		else
520	<	if (IsEditableTextKey(Key) or (Key = VK_BACK))
521	<	and AutoComplete and (Style <> csDropDownList) and
522	<	(not (cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
523	<	FTimer.Interval := FKeyPressInterval
524	<	else
525	<	FTimer.Interval := 0
520	>	if AutoComplete and (Style <> csDropDownList) then
521	>	begin
522	>	if (Key = VK_BACK) or (Key = VK_DELETE) then
523	>	begin
524	>	if SelStart = 0 then
525	>	begin
526	>	SelStart := UTF8Length(Text);
527	>	SelLength := 0;
528	>	end;
529	>	FTimer.Interval := 0;
530	>	end
531	>	else
532	>	if IsEditableTextKey(Key) and
533	>	(not(cbactEndOfLineComplete in AutoCompleteText) or (SelStart = UTF8Length(Text))) then
534	>	begin
535	>	FTimer.Interval := 0;
536	>	FTimer.Interval := FKeyPressInterval;
537	>	end;
538	>	end;
539	>	end;
540	>
541	>	procedure TIBLookupComboEditBox.Loaded;
542	>	begin
543	>	inherited Loaded;
544	>	IBControlLinkChanged;
545	>	end;
546	>
547	>	procedure TIBLookupComboEditBox.Notification(AComponent: TComponent;
548	>	Operation: TOperation);
549	>	begin
550	>	inherited Notification(AComponent, Operation);
551	>	if (Operation = opRemove) and (AComponent = DataSource) then
552	>	ListSource := nil;
553		end;
554
555		procedure TIBLookupComboEditBox.SetItemIndex(const Val: integer);
556		begin
557	+	if Val > 0 then
558	+	FCurText := '';
559		inherited SetItemIndex(Val);
560		FLastKeyValue := KeyValue;
561		end;
562
563	+	function TIBLookupComboEditBox.SQLSafe(aText: string): string;
564	+	var I: integer;
565	+	begin
566	+	Result := '';
567	+	for I := 1 to length(aText) do
568	+	if aText[I] = '''' then
569	+	Result := Result + ''''''
570	+	else
571	+	Result := Result + aText[I];
572	+	end;
573	+
574		procedure TIBLookupComboEditBox.UpdateShowing;
575		begin
576		inherited UpdateShowing;
#	Line 474 | Line 578 | begin
578		ActiveChanged(nil);
579		end;
580
581	+	procedure TIBLookupComboEditBox.UpdateData(Sender: TObject);
582	+	begin
583	+	inherited UpdateData(Sender);
584	+	if FCurText <> '' then
585	+	Text := FCurText + Text;
586	+	FModified := false;
587	+	end;
588	+
589	+	{$if lcl_fullversion >= 2000003}
590	+	type
591	+
592	+	{ THackedCustomComboBox }
593	+
594	+	THackedCustomComboBox = class(TCustomComboBox)
595	+	private
596	+	procedure CallChange;
597	+	end;
598	+
599	+	{ THackedCustomComboBox }
600	+
601	+	procedure THackedCustomComboBox.CallChange;
602	+	begin
603	+	inherited Change;
604	+	end;
605	+
606	+	procedure TIBLookupComboEditBox.Change;
607	+	begin
608	+	THackedCustomComboBox(self).CallChange;
609	+	end;
610	+
611	+	procedure TIBLookupComboEditBox.CloseUp;
612	+	begin
613	+	inherited CloseUp;
614	+	inherited DoEdit;
615	+	end;
616	+
617	+	procedure TIBLookupComboEditBox.Select;
618	+	begin
619	+	inherited Select;
620	+	inherited DoEdit;
621	+	end;
622	+
623	+	function TIBLookupComboEditBox.DoEdit: boolean;
624	+	begin
625	+	{DoEdit will swallow characters if no editable Field. Hence, to enabled
626	+	writing we must avoid calling the inherited method.}
627	+	if IsUnbound then
628	+	Result := true
629	+	else
630	+	Result := inherited DoEdit;
631	+	end;
632	+	{$ifend}
633	+
634		constructor TIBLookupComboEditBox.Create(TheComponent: TComponent);
635		begin
636		inherited Create(TheComponent);
637		FDataLink := TIBLookupComboDataLink.Create(self);
638	<	FKeyPressInterval := 500;
638	>	FIBLookupControlLink := TIBLookupControlLink.Create(self);
639	>	FKeyPressInterval := 200;
640		FAutoComplete := true;
641		FTimer := TTimer.Create(nil);
642		FTimer.Interval := 0;
#	Line 489 | Line 647 | end;
647		destructor TIBLookupComboEditBox.Destroy;
648		begin
649		if assigned(FDataLink) then FDataLink.Free;
650	+	if assigned(FIBLookupControlLink) then FIBLookupControlLink.Free;
651		if assigned(FTimer) then FTimer.Free;
652	+	Application.RemoveAsyncCalls(self);
653		inherited Destroy;
654		end;
655
656		procedure TIBLookupComboEditBox.EditingDone;
657		begin
658	+	FForceAutoComplete := true;
659	+	try
660	+	if FTimer.Interval <> 0 then
661	+	HandleTimer(nil);
662	+	finally
663	+	FForceAutoComplete := false;
664	+	end;
665		CheckAndInsert;
666	+	FCurText := '';
667	+	if FModified then
668	+	Change; {ensure Update}
669		inherited EditingDone;
670		end;
671

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines