Context Navigation

TMGHTML2.~pas@ 1245

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

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

Download in other formats:

Original Format