ViewVC Help

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

root/public/ibx/branches/journaling/ibcontrols/IBLookupComboEditBox.pas

Comparing ibx/trunk/ibcontrols/IBLookupComboEditBox.pas (file contents):
Revision 23 by tony, Fri Mar 13 10:26:52 2015 UTC vs.
Revision 263 by tony, Thu Dec 6 15:55:01 2018 UTC

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

Diff Legend

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