Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

TMGHTML2.~pas@ 541

Last change on this file since 541 was 541, checked in by Kevin Toppenberg, 15 years ago
TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 29.1 KB

Line
1	unit TMGHTML2;
2
3	(*
4	NOTES: By Kevin Toppenberg, MD 5/27/09
5
6	Code heavily modified from original code found at www.supermemo.com/source/
7	Their notes (below) indicate that the code may be freely used.
8	---------------
9	This unit encapsulates SHDocVw.dll and MSHTML.dll functionality by subclassing
10	THtmlEditorBrowser object as THtmlEditor object
11
12	THtmlEditor was designed for easy use of HTML display and editing capacity in
13	SuperMemo 2002 for Windows developed by SuperMemo R&D in Fall 2001.
14
15	SuperMemo 2002 implements HTML-based incremental reading in which extensive HTML
16	support is vital.
17
18	Pieces of this units can be used by anyone in other Delphi applications that make
19	use of HTML WYSIWYG interfaces made open by Microsoft.
20	*)
21
22	(*
23	NOTICE: Also Derived from EmbeddedED. See notes in that code block.
24	*)
25
26	interface
27
28	uses SysUtils, WinTypes, Dialogs, StdCtrls, Menus,
29	EmbeddedED,
30	ActiveX, MSHTMLEvents, SHDocVw, {MSHTML,} MSHTML_EWB,
31	AppEvnts, controls,
32	IeConst,Messages,Classes,Forms,Graphics;
33
34	type
35	TSetFontMode = (sfAll,sfSize,sfColor,sfName,sfStyle,sfCharset);
36
37	TRGBColor = record
38	R : byte;
39	G : byte;
40	B : byte;
41	end; {record}
42
43	TMGColor = record
44	case boolean of
45	True: (Color : TColor);
46	False: (RGBColor : TRGBColor);
47	end; {record}
48
49	type
50	// THtmlObj=class(TWebBrowser)
51	THtmlObj=class(TEmbeddedED)
52	private
53	CtrlToBeProcessed : boolean;
54	ShiftToBeProcessed : boolean;
55	CtrlReturnToBeProcessed: boolean;
56	Modified: boolean;
57	FOrigAppOnMessage : TMessageEvent;
58	FApplication : TApplication;
59	FActive : boolean;
60	FEditable: boolean;
61	ColorDialog: TColorDialog;
62	AllowNextBlur : boolean;
63	procedure SetMsgActive (Active : boolean);
64	function GetHTMLText:string;
65	procedure SetHTMLText(HTML:String);
66	function GetText:string;
67	procedure SetText(HTML:string);
68	function GetEditableState : boolean;
69	procedure SetEditableState (EditOn : boolean);
70	procedure SetBackgroundColor(Color:TColor);
71	function GetBackgroundColor : TColor;
72	function ColorToMSHTMLStr(color : TColor) : string;
73	function MSHTMLStrToColor(MSHTMLColor : string) : TColor;
74	procedure SetTextForegroundColor(Color:TColor);
75	function GetTextForegroundColor : TColor;
76	procedure SetTextBackgroundColor(Color:TColor);
77	function GetTextBackgroundColor : TColor;
78	function GetFontSize : integer;
79	procedure SetFontSize (Size : integer);
80	function GetFontName : string;
81	procedure SetFontName (Name : string);
82	function GetSelText:string;
83	procedure SetSelText (HTMLText : string);
84	procedure ReassignKeyboardHandler(TurnOn : boolean);
85	procedure GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
86	procedure HandleBlur(Sender: TObject);
87	procedure SubMessageHandler(var Msg: TMessage); override;
88	function SubFocusHandler(fGotFocus: BOOL): HResult; override;
89	function GetActive : boolean;
90	{end private}
91	public
92	{end public}
93	PopupMenu: TPopupMenu;
94	KeyStruck : boolean; // A VERY crude determiner as to if Modified.
95	NextControl : TWinControl;
96	PrevControl : TWinControl;
97	constructor Create(Owner:TControl; Application : TApplication);
98	destructor Destroy; override;
99	procedure Clear;
100	procedure ToggleBullet;
101	procedure ToggleItalic;
102	procedure ToggleBold;
103	procedure ToggleNumbering;
104	procedure ToggleUnderline;
105	procedure ToggleSubscript;
106	procedure ToggleSuperscript;
107	procedure Indent;
108	procedure Outdent;
109	procedure AlignLeft;
110	procedure AlignRight;
111	procedure AlignCenter;
112	procedure TextForeColorDialog;
113	procedure TextBackColorDialog;
114	procedure FontDialog;
115	function SelStart:integer;
116	function SelEnd:integer;
117	function SelLength:integer;
118	function GetTextRange:IHtmlTxtRange;
119	procedure ReplaceSelection(HTML:string);
120	procedure Loaded; Override;
121	function GetTextLen : integer;
122	function MoveCaretToEnd : boolean;
123	function MoveCaretToPos(ScreenPos: TPoint) : HRESULT; //kt added
124	procedure InsertTextAtCaret(Text : AnsiString); //Note: Text is NOT HTMLtext
125	property HTMLText:string read GetHTMLText write SetHTMLText;
126	property Text:string read GetText write SetText;
127	//property Active : boolean read FActive write SetMsgActive;
128	property Active : boolean read GetActive;
129	property Editable : boolean read GetEditableState write SetEditableState;
130	property BackgroundColor : TColor read GetBackgroundColor write SetBackgroundColor;
131	property FontSize : integer read GetFontSize write SetFontSize;
132	property FontName : string read GetFontName write SetFontName;
133	property SelText : string read GetSelText write SetSelText;
134	end;
135
136	implementation
137
138
139	uses
140	WinProcs,Variants,Clipbrd, StrUtils, Math,
141	Windows;
142
143	const
144	FontScale=3;
145	MaxTextLength = 100;
146	nl = #13#10;
147
148	procedure EError(EText : string; E : Exception);
149	begin
150	MessageDlg(EText,mtError,[mbOK],0);
151	end;
152
153
154	constructor THtmlObj.Create(Owner:TControl; Application : TApplication);
155	begin
156	inherited Create(Owner); //Note: Owner should be a descendant of TControl;
157	FApplication := Application;
158	FOrigAppOnMessage := Application.OnMessage;
159	OnBlur := HandleBlur;
160	AllowNextBlur := false;
161	KeyStruck := false;
162	NextControl := nil;
163	PrevControl := nil;
164	end;
165
166	destructor THtmlObj.Destroy;
167	begin
168	SetMsgActive(false); //Turns off local OnMessage handling
169	inherited Destroy;
170	end;
171
172	procedure THtmlObj.SetMsgActive (Active : boolean);
173	//NOTE: This object grabs the OnMessage for the entire application, so that
174	// it can intercept the right-click. As a result, the object needs a
175	// way that it can turn off this feature when it is covered up by other
176	// windows application subwindows etc. This function provides this.
177	begin
178	FActive := Active;
179	ReassignKeyboardHandler(FActive);
180	end;
181
182	procedure THtmlObj.SetHTMLText(Html : String);
183	var //V : OleVariant;
184	V2 : variant;
185	body : IHTMLElement;
186	status : string;
187	temp : string;
188	begin
189	DocumentHTML := Html;
190	exit; //kt
191	(*
192	try
193	Stop;
194	if Doc =nil then exit;
195	body := Doc.body;
196
197	if UpperCase(Doc.designMode) <> 'ON' then begin
198	Doc.designMode := 'on';
199	repeat //NOTE: potential endless loop. Perhaps loop only status='loading'?
200	status := Doc.readyState;
201	{Possible status values:
202	uninitialized -- Object is not initialized with data.
203	loading -- Object is loading its data.
204	loaded -- Object has finished loading its data.
205	interactive -- User can interact with the object even though it is not fully loaded.
206	complete -- Object is completely initialized. }
207	if status <> 'complete' then FApplication.ProcessMessages;
208	until (status = 'complete') or (status='interactive') or (status='loaded');
209	end;
210	body := Doc.body;
211	if (body = nil) then begin //Do so stuff to get IE to make a 'body'.
212	V2 := VarArrayCreate([0, 0], VarVariant);
213	V2[0] := ' '; //Html;
214	Doc.Write(PSafeArray(System.TVarData(V2).VArray));
215	body := Doc.body;
216	Doc.close;
217	repeat
218	status := Doc.readyState; //For possible status values, see above)
219	if status <> 'complete' then FApplication.ProcessMessages;
220	until (status = 'complete') or (status='interactive') or (status='loaded');
221	body := Doc.body;
222	end;
223	body.innerHTML := Html;
224	temp := body.innerHTML; //to test if it was set or not...
225	Modified:=true;
226	except
227	on E:Exception do EError('Error setting HTML text',E);
228	end;
229	*)
230	end;
231
232
233	function THtmlObj.GetHTMLText:string;
234	var WS:WideString;
235	ch:WideChar;
236	n:integer;
237	w:word;
238	s:string;
239	begin
240	//Result:=DocumentHTML;
241	Result:='';
242	if Doc=nil then exit;
243	WS:=Doc.body.innerHTML;
244	for n:=1 to length(WS) do begin
245	ch := WS[n];
246	w := word(ch);
247	if w>255 then begin
248	s:=IntToStr(w);
249	s:='&#'+s+';';
250	end else s:=ch;
251	Result:=Result+s;
252	end;
253	end;
254
255	function THtmlObj.GetText:string;
256	var WS:WideString;
257	ch:WideChar;
258	n:integer;
259	w:word;
260	s:string;
261	begin
262	Result:='';
263	if DOC=nil then exit;
264	WS:=Doc.body.innerText;
265	for n:=1 to length(WS) do begin
266	ch:=WS[n];
267	w:=word(ch);
268	if w>255 then begin
269	w:=(w mod 256)+48;
270	s:=IntToStr(w);
271	s:=char(w);
272	end else s:=ch;
273	Result:=Result+s;
274	end;
275	end;
276
277	procedure THtmlObj.SetText(HTML:string);
278	begin
279	if (DOC=nil)or(DOC.body=nil) then SetHTMLText(HTML)
280	else DOC.body.innerHTML:=HTML;
281	end;
282
283	procedure THtmlObj.Clear;
284	begin
285	//kt if IsDirty then
286	NewDocument;
287	KeyStruck := false;
288	//SetHTMLText('');
289	end;
290
291	function THtmlObj.GetEditableState : boolean;
292	var mode : string;
293	begin
294	mode := Doc.designMode;
295	result := (mode = 'On');
296	end;
297
298	procedure THtmlObj.SetEditableState(EditOn : boolean);
299	var LastMode : string;
300	count : integer;
301	begin
302	LastMode := 'Inherit';
303	try
304	count := 0;
305	repeat
306	inc (count);
307	if Doc = nil then begin
308	FApplication.ProcessMessages;
309	Sleep (100);
310	continue;
311	end else if Doc.body = nil then begin
312	FApplication.ProcessMessages;
313	Sleep (100);
314	continue;
315	end;
316	if EditOn then begin
317	Doc.body.setAttribute('contentEditable','true',0);
318	Doc.designMode := 'On'; //kt
319	FEditable:=true;
320	//SetFocus;
321	end else begin
322	Doc.body.setAttribute('contentEditable','false',0);
323	Doc.designMode := 'Off'; //kt
324	FEditable:=false;
325	end;
326	LastMode := Doc.designMode;
327	until (LastMode <> 'Inherit') or (count > 20);
328	except
329	on E:Exception do EError('Error switching into HTML editing state',E);
330	end;
331	end;
332
333	procedure THtmlObj.SetBackgroundColor(Color:TColor);
334	begin
335	if Doc=nil then exit;
336	//WaitLoad(true); //kt
337	WaitForDocComplete;
338	if Doc.body=nil then exit;
339	Doc.body.style.backgroundColor := ColorToMSHTMLStr(Color);
340	end;
341
342	function THtmlObj.GetBackgroundColor : TColor;
343	begin
344	Result := clBlack; //default;
345	if Doc=nil then exit;
346	if Doc.body=nil then exit;
347	Result := MSHTMLStrToColor(Doc.body.style.backgroundColor);
348	end;
349
350	function THtmlObj.ColorToMSHTMLStr(color : TColor) : string;
351	//Note: TColor stores colors lo-byte --> hi-byte as RGB
352	//Function returns '#RRGGBB'
353	var tempColor : TMGColor;
354	begin
355	tempColor.Color := color;
356	Result := '#'+
357	IntToHex(tempColor.RGBColor.R,2)+
358	IntToHex(tempColor.RGBColor.G,2)+
359	IntToHex(tempColor.RGBColor.B,2);
360	end;
361
362	function THtmlObj.MSHTMLStrToColor(MSHTMLColor : string) : TColor;
363	//Function converts '#RRGGBB' -- TColor
364	//Note: TColor stores colors lo-byte --> hi-byte as RGB
365	var tempColor : TMGColor;
366	strHexRed,strHexGreen,strHexBlue : string[2];
367	begin
368	Result := clBlack; //FIX!!!! IMPLEMENT LATER...
369	if Pos('#',MSHTMLColor)=1 then begin
370	// MSHTMLColor := MidStr(MSHTMLColor,2,99);
371	strHexRed := MidStr(MSHTMLColor,2,2);
372	strHexGreen := MidStr(MSHTMLColor,4,2);
373	strHexBlue := MidStr(MSHTMLColor,6,2);
374	tempColor.RGBColor.R := StrToIntDef('$'+StrHexRed,0);
375	tempColor.RGBColor.G := StrToIntDef('$'+StrHexGreen,0);
376	tempColor.RGBColor.B := StrToIntDef('$'+StrHexBlue,0);
377	Result := tempColor.Color;
378	//NOTE: This function has not yet been tested....
379	end;
380	end;
381
382	procedure THtmlObj.ToggleBullet;
383	begin
384	if DOC=nil then exit;
385	//SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
386	DOC.execCommand('InsertUnorderedList',false,null);
387	Modified:=true;
388	end;
389
390	procedure THtmlObj.ToggleItalic;
391	begin
392	if DOC=nil then exit;
393	DOC.execCommand('Italic',false,null);
394	Modified:=true;
395	end;
396
397	procedure THtmlObj.ToggleBold;
398	begin
399	if DOC=nil then exit;
400	DOC.execCommand('Bold',false,null);
401	Modified:=true;
402	end;
403
404	procedure THtmlObj.ToggleNumbering;
405	begin
406	if DOC=nil then exit;
407	DOC.execCommand('InsertOrderedList',false,null);
408	// SpecialCommand(IDM_ORDERLIST,false,true,false,Null);
409	Modified:=true;
410	end;
411
412	procedure THtmlObj.ToggleUnderline;
413	begin
414	if DOC=nil then exit;
415	DOC.execCommand('Underline',false,null);
416	Modified:=true;
417	end;
418
419	procedure THtmlObj.ToggleSubscript;
420	begin
421	if DOC=nil then exit;
422	DOC.execCommand('Subscript',False,0);
423	Modified:=true;
424	end;
425
426	procedure THtmlObj.ToggleSuperscript;
427	begin
428	if DOC=nil then exit;
429	DOC.execCommand('Superscript',False,0);
430	Modified:=true;
431	end;
432
433
434	procedure THtmlObj.Indent;
435	begin
436	if DOC=nil then exit;
437	DOC.ExecCommand('Indent',false,0);
438	Modified:=true;
439	end;
440
441	procedure THtmlObj.Outdent;
442	begin
443	if DOC=nil then exit;
444	DOC.ExecCommand('Outdent',false,0);
445	Modified:=true;
446	end;
447
448
449	procedure THtmlObj.AlignLeft;
450	begin
451	if DOC=nil then exit;
452	DOC.ExecCommand('JustifyLeft',false,0);
453	Modified:=true;
454	end;
455
456	procedure THtmlObj.AlignRight;
457	begin
458	if DOC=nil then exit;
459	DOC.ExecCommand('JustifyRight',false,0);
460	Modified:=true;
461	end;
462
463	procedure THtmlObj.AlignCenter;
464	begin
465	if DOC=nil then exit;
466	DOC.ExecCommand('JustifyCenter',false,0);
467	Modified:=true;
468	end;
469
470	procedure THtmlObj.TextForeColorDialog;
471	begin
472	if ColorDialog = nil then begin
473	ColorDialog := TColorDialog.Create(self);
474	end;
475	if ColorDialog.Execute then begin
476	SetTextForegroundColor(ColorDialog.Color);
477	end;
478	Modified:=true;
479	end;
480
481	procedure THtmlObj.TextBackColorDialog;
482	begin
483	if ColorDialog = nil then begin
484	ColorDialog := TColorDialog.Create(self);
485	end;
486	if ColorDialog.Execute then begin
487	SetTextBackgroundColor(ColorDialog.Color);
488	end;
489	Modified:=true;
490	end;
491
492	procedure THtmlObj.SetTextForegroundColor(Color:TColor);
493	begin
494	if DOC=nil then exit;
495	DOC.ExecCommand('ForeColor',false,Color);
496	Modified:=true;
497	end;
498
499	function THtmlObj.GetTextForegroundColor:TColor;
500	var Background : OleVariant;
501	vt : TVarType;
502	begin
503	Result:=clWindow;
504	try
505	if DOC=nil then exit;
506	Background:=DOC.queryCommandValue('ForeColor');
507	vt:=varType(Background);
508	if vt<>varNull then Result:=Background;
509	except
510	on E:Exception do EError('Error retrieving foreground color',E);
511	end;
512	end;
513
514	procedure THtmlObj.SetTextBackgroundColor(Color:TColor);
515	begin
516	if DOC=nil then exit;
517	DOC.ExecCommand('BackColor',false,Color);
518	Modified:=true;
519	end;
520
521	function THtmlObj.GetTextBackgroundColor:TColor;
522	var Background : OleVariant;
523	vt : TVarType;
524	begin
525	Result:=clWindow;
526	try
527	if DOC=nil then exit;
528	Background:=DOC.queryCommandValue('BackColor');
529	vt:=varType(Background);
530	if vt<>varNull then Result:=Background;
531	except
532	on E:Exception do EError('Error retrieving background color',E);
533	end;
534	end;
535
536	procedure THtmlObj.FontDialog;
537	begin
538	DoCommand(IDM_FONT);
539	Modified:=true;
540	end;
541
542	function THtmlObj.GetFontSize : integer;
543	var FontSize : OleVariant;
544	vt : TVarType;
545
546	begin
547	FontSize:=Doc.queryCommandValue('FontSize');
548	vt:=varType(FontSize);
549	if vt<>varNull then Result := FontSize*FontScale
550	else Result :=12*FontScale; //kt
551	end;
552
553	procedure THtmlObj.SetFontSize (Size : integer);
554	begin
555	if Doc=nil then exit;
556	Doc.ExecCommand('FontSize', false, Size div FontScale);
557	end;
558
559	function THtmlObj.GetFontName : string;
560	var FontName :OleVariant;
561	vt : TVarType;
562	begin
563	if DOC=nil then exit;
564	FontName:=DOC.queryCommandValue('FontName');
565	vt:=varType(FontName);
566	if vt<>varNull then Result := FontName
567	else Result :='Times New Roman'; //kt
568	end;
569
570	procedure THtmlObj.SetFontName (Name : string);
571	begin
572	if DOC=nil then exit;
573	DOC.ExecCommand('FontName', false, Name);
574	end;
575
576	function THtmlObj.SelStart:integer;
577	var TextRange:IHtmlTxtRange;
578	begin
579	Result:=0;
580	TextRange:=GetTextRange;
581	if TextRange=nil then exit;
582	Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
583	end;
584
585	function THtmlObj.SelEnd:integer;
586	var TextRange:IHtmlTxtRange;
587	begin
588	Result:=0;
589	TextRange:=GetTextRange;
590	if TextRange=nil then exit;
591	Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
592	end;
593
594	function THtmlObj.SelLength:integer;
595	begin
596	Result:=SelEnd-SelStart;
597	end;
598
599	function THtmlObj.GetTextRange:IHtmlTxtRange;
600	begin
601	Result:=nil;
602	try
603	if DOC=nil then exit;
604	while DOC.body=nil do begin
605	//WaitLoad(true); //kt
606	WaitForDocComplete;
607	if DOC.body=nil then begin
608	if MessageDlg('Wait for document loading?',mtConfirmation,
609	[mbOK,mbCancel],0) <> mrOK then begin
610	exit;
611	end;
612	end;
613	end;
614	if (DOC.Selection.type_='Text') or (DOC.Selection.type_='None') then begin
615	Result:=DOC.Selection.CreateRange as IHtmlTxtRange;
616	end;
617	except
618	on E:Exception do EError('This type of selection cannot be processed',E);
619	end;
620	end;
621
622	function THtmlObj.GetSelText:string;
623	var TextRange:IHtmlTxtRange;
624	begin
625	Result:='';
626	TextRange:=GetTextRange;
627	if TextRange=nil then
628	exit;
629	Result:=TextRange.text;
630	end;
631
632	procedure THtmlObj.SetSelText (HTMLText : string);
633	begin
634	ReplaceSelection(HTMLText);
635	end;
636
637	procedure THtmlObj.ReplaceSelection(HTML:string);
638	var TextRange:IHtmlTxtRange;
639	begin
640	try
641	TextRange:=GetTextRange;
642	if TextRange=nil then exit;
643	TextRange.PasteHTML(HTML);
644	Modified:=true;
645	except
646	on E:Exception do begin
647	// implement later... ShortenString(HTML,80);
648	EError('Error pasting HTML'+nl+
649	'Microsoft HTML refuses to paste this string:'+nl+
650	HTML+nl,E);
651	end;
652	end;
653	end;
654
655
656	function THtmlObj.MoveCaretToEnd : boolean;
657	//kt added
658	var //TextRange:IHtmlTxtRange;
659	count : integer;
660	begin
661	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_BottomOfWindow,0));
662	count := 0;
663	repeat
664	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_NextLine,-1));
665	inc (count);
666	until (Result = false) or (count > 500);
667	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_CurrentLineEnd,0));
668	Result:=(S_OK = FCaret.MoveCaretToPointer(FTMGDisplayPointer,
669	integer(FALSE),
670	CARET_DIRECTION_SAME));
671	{
672	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
673	SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
674	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
675	SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
676	}
677	end;
678
679	function THtmlObj.MoveCaretToPos(ScreenPos: TPoint) : HRESULT;
680	//kt added entire function
681	var OutTemp : DWORD;
682	begin
683	if not assigned (FTMGDisplayPointer) then exit;
684	FTMGDisplayPointer.moveToPoint(ScreenPos, COORD_SYSTEM_GLOBAL, nil, HT_OPT_AllowAfterEOL, OutTemp);
685	Result := FCaret.MoveCaretToPointer(FTMGDisplayPointer,Integer(True),CARET_DIRECTION_INDETERMINATE);
686	FCaret.Show(Integer(True));
687	end;
688
689	procedure THtmlObj.InsertTextAtCaret(Text : AnsiString);
690	//kt added. Note: inserts external format (not HTML markup)
691	var P : PWideChar;
692	begin
693	P := StringToOleStr(Text);
694	FCaret.InsertText(P,Length(Text))
695	end;
696
697
698	procedure THtmlObj.Loaded;
699	begin
700	inherited Loaded;
701	end;
702
703	function THtmlObj.GetTextLen : integer;
704	begin
705	Result := Length(GetText);
706	end;
707
708
709	procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
710	{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
711	begin
712	if TurnOn then begin
713	FApplication.OnMessage := GlobalMsgHandler;
714	end else begin
715	FApplication.OnMessage := FOrigAppOnMessage;
716	end;
717	end;
718
719	procedure THtmlObj.GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
720	{NOTE: This message handler will receive ALL messages directed to CPRS. I
721	have to do this, because something is filtering messages before they
722	get to this THTMLObj object. My goal is to do as little here as possible,
723	and let the OnMessage for THTMLObj (found in EmbeddedED) take care of the rest.
724	NOTE: This should get activated by OnFocus for object, and deactivated
725	by OnBlur, so it actually should only get messages when focused. }
726	var
727	i : Integer;
728	NewMsg : TMessage;
729
730	function TransformMessage (WinMsg : TMsg) : TMessage;
731	begin
732	Result.Msg := WinMsg.message;
733	Result.WParam := WinMsg.wParam;
734	Result.LParam := WinMsg.lParam;
735	Result.Result := 0;
736	end;
737
738	begin
739	Handled:=false; //default to not handled
740	if (Msg.Message=WM_KEYDOWN) then begin
741	if (Msg.WParam=VK_UP) or (Msg.WParam=VK_DOWN) or (Msg.WParam=VK_TAB) then begin
742	NewMsg := TransformMessage(Msg);
743	SubMessageHandler(NewMsg);
744	Handled := (NewMsg.Result = 1);
745	end;
746	end;
747	end;
748
749
750	procedure THtmlObj.SubMessageHandler(var Msg: TMessage);
751	//Called from parent's EDMessageHandler, or from GlobalMsgHandler
752	var i : Integer;
753	WinControl : TWinControl;
754
755	begin
756	Msg.Result := 0; //default to not handled
757	if not ((Msg.Msg=WM_KEYDOWN) or
758	(Msg.Msg=WM_KEYUP) or
759	(Msg.Msg=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
760	case Msg.Msg of
761	WM_RBUTTONUP : begin
762	if CtrlToBeProcessed then begin
763	CtrlToBeProcessed := false;
764	exit; //Ctrl-right click is ignored
765	end;
766	if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
767	Msg.Result := 1; //Handled
768	exit;
769	end;
770	WM_KEYDOWN : begin
771	GetSystemTimeAsFileTime(KeyPressTime);
772	KeyStruck := true;
773	//beep(200,50);
774	case Msg.WParam of
775	VK_ESCAPE : begin
776	if Assigned(PrevControl) then begin
777	AllowNextBlur := true;
778	PrevControl.SetFocus;
779	end;
780	end;
781	VK_CONTROL : begin
782	CtrlToBeProcessed:=true;
783	Msg.Result := 1; //Handled
784	exit;
785	end;
786	VK_SHIFT : begin
787	ShiftToBeProcessed:=true;
788	Msg.Result := 1; //Handled
789	exit;
790	end;
791	VK_TAB : begin
792	if (ShiftToBeProcessed and CtrlToBeProcessed) then begin
793	//This isn't working for some reason...
794	for i := 0 to 5 do begin
795	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_LEFT, 0);
796	end;
797	ShiftToBeProcessed := false;
798	CtrlToBeProcessed := false;
799	end else if ShiftToBeProcessed then begin
800	if Assigned(PrevControl) then begin
801	AllowNextBlur := true;
802	PrevControl.SetFocus;
803	end;
804	ShiftToBeProcessed := false;
805	end else if CtrlToBeProcessed then begin
806	if Assigned(NextControl) then begin
807	AllowNextBlur := true;
808	NextControl.SetFocus;
809	end;
810	CtrltoBeProcessed := false;
811	end else begin
812	for i := 0 to 5 do begin
813	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_SPACE, 0);
814	end;
815	end;
816	Msg.Result := 1; //Handled
817	end;
818	{
819	VK_RETURN : if CtrlReturnToBeProcessed then begin
820	Msg.Result := 1; //Handled
821	CtrlReturnToBeProcessed := false;
822	end else if CtrlToBeProcessed then begin
823	Msg.Result := 1; //Handled
824	CtrlToBeProcessed := False;
825	CtrlReturnToBeProcessed := true;
826	//PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
827	end else if ShiftToBeProcessed=false then begin
828	//kt if not FEditable then exit;
829	keybd_event(VK_SHIFT,0,0,0);
830	keybd_event(VK_RETURN,0,0,0);
831	keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
832	Msg.Result := 1; //Handled
833	end;
834	}
835	Ord('B') : if CtrlToBeProcessed then begin
836	//kt if not FEditable then exit;
837	ToggleBold;
838	Msg.Result := 1; //Handled
839	exit;
840	end;
841	Ord('U') : if CtrlToBeProcessed then begin
842	//kt if not FEditable then exit;
843	ToggleUnderline;
844	Msg.Result := 1; //Handled
845	exit;
846	end;
847	Ord('I') : if CtrlToBeProcessed then begin
848	//kt if not FEditable then exit;
849	ToggleItalic;
850	Msg.Result := 1; //Handled
851	end;
852	end; {case}
853	end;
854	WM_KEYUP : begin
855	case Msg.WParam of
856	VK_CONTROL : begin
857	CtrlToBeProcessed:=false;
858	Msg.Result := 1; //Handled
859	if CtrlReturnToBeProcessed then begin
860	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_RETURN, 0);
861	end;
862	exit;
863	end;
864	VK_SHIFT : begin
865	ShiftToBeProcessed:=false;
866	Msg.Result := 1; //Handled
867	exit;
868	end;
869
870	end; {case}
871	exit;
872	end;
873	end; {case}
874	end;
875
876	procedure THtmlObj.HandleBlur(Sender: TObject);
877	//kt added function
878	function RecentKeyPressed : boolean;
879	var NowTime : FILETIME; //kt
880	KeyTime,NowTime2 : LARGE_INTEGER;
881	Delta : int64;
882	begin
883	GetSystemTimeAsFileTime(NowTime);
884	NowTime2.LowPart := NowTime.dwLowDateTime;
885	NowTime2.HighPart := NowTime.dwHighDateTime;
886	KeyTime.LowPart := KeyPressTime.dwLowDateTime;
887	KeyTime.HighPart := KeyPressTime.dwHighDateTime;
888	Delta := floor( (NowTime2.QuadPart - KeyTime.QuadPart) / 100000);
889	Result := (Delta < 100);
890	end;
891
892	begin
893	//kt Handle loss of focus when attempting to cursor above top line, or below bottom line.
894	if (not AllowNextBlur) and RecentKeyPressed then begin //kt entire block
895	SetFocusToDoc;
896	//beep(880,100);
897	KeyPressTime.dwLowDateTime := 0;
898	KeyPressTime.dwHighDateTime := 0;
899	exit;
900	end;
901	AllowNextBlur := false;
902	SetMsgActive(false);
903	end;
904
905	function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
906	begin
907	SetMsgActive(fGotFocus);
908	end;
909
910	function THtmlObj.GetActive : boolean;
911	begin
912	Result := TWinControl(Owner).Visible;
913	end;
914
915
916	initialization
917
918	finalization
919
920	end.
921

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format