Context Navigation

TMGHTML2.pas@ 1806

Last change on this file since 1806 was 793, checked in by Kevin Toppenberg, 15 years ago
update
File size: 32.6 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:= 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
766	const
767	FontSizes : array [0..6] of byte = (8,10,12,14,18,24,36);
768
769	var i : Integer;
770	WinControl : TWinControl;
771	TextSize : integer;
772
773	begin
774	Msg.Result := 0; //default to not handled
775	if not ((Msg.Msg=WM_KEYDOWN) or
776	(Msg.Msg=WM_KEYUP) or
777	(Msg.Msg=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
778	case Msg.Msg of
779	WM_RBUTTONUP : begin
780	if CtrlToBeProcessed then begin
781	CtrlToBeProcessed := false;
782	exit; //Ctrl-right click is ignored
783	end;
784	if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
785	Msg.Result := 1; //Handled
786	exit;
787	end;
788	WM_KEYDOWN : begin
789	GetSystemTimeAsFileTime(KeyPressTime);
790	KeyStruck := true;
791	//beep(200,50);
792	case Msg.WParam of
793	VK_ESCAPE : begin
794	if Assigned(PrevControl) then begin
795	AllowNextBlur := true;
796	PrevControl.SetFocus;
797	end;
798	end;
799	VK_CONTROL : begin
800	CtrlToBeProcessed:=true;
801	Msg.Result := 1; //Handled
802	exit;
803	end;
804	VK_SHIFT : begin
805	ShiftToBeProcessed:=true;
806	Msg.Result := 1; //Handled
807	exit;
808	end;
809	VK_TAB : begin
810	if (ShiftToBeProcessed and CtrlToBeProcessed) then begin
811	//This isn't working for some reason...
812	for i := 0 to 5 do begin
813	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_LEFT, 0);
814	end;
815	ShiftToBeProcessed := false;
816	CtrlToBeProcessed := false;
817	end else if ShiftToBeProcessed then begin
818	if Assigned(PrevControl) then begin
819	AllowNextBlur := true;
820	PrevControl.SetFocus;
821	end;
822	ShiftToBeProcessed := false;
823	end else if CtrlToBeProcessed then begin
824	if Assigned(NextControl) then begin
825	AllowNextBlur := true;
826	NextControl.SetFocus;
827	end;
828	CtrltoBeProcessed := false;
829	end else begin
830	for i := 0 to 5 do begin
831	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_SPACE, 0);
832	end;
833	end;
834	Msg.Result := 1; //Handled
835	end;
836	$31..$38 : begin
837	if CtrlToBeProcessed = true then begin
838	TextSize := Msg.WParam-$31;
839	if (TextSize >= 0) and (TextSize <=6 ) then begin
840	SetFontSize(FontSizes[TextSize]);
841	CtrlToBeProcessed := False;
842	end;
843	end;
844	end;
845	{
846	VK_RETURN : if CtrlReturnToBeProcessed then begin
847	Msg.Result := 1; //Handled
848	CtrlReturnToBeProcessed := false;
849	end else if CtrlToBeProcessed then begin
850	Msg.Result := 1; //Handled
851	CtrlToBeProcessed := False;
852	CtrlReturnToBeProcessed := true;
853	//PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
854	end else if ShiftToBeProcessed=false then begin
855	//kt if not FEditable then exit;
856	keybd_event(VK_SHIFT,0,0,0);
857	keybd_event(VK_RETURN,0,0,0);
858	keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
859	Msg.Result := 1; //Handled
860	end;
861	}
862	Ord('B') : if CtrlToBeProcessed then begin
863	//kt if not FEditable then exit;
864	ToggleBold;
865	Msg.Result := 1; //Handled
866	exit;
867	end;
868	Ord('U') : if CtrlToBeProcessed then begin
869	//kt if not FEditable then exit;
870	ToggleUnderline;
871	Msg.Result := 1; //Handled
872	exit;
873	end;
874	Ord('I') : if CtrlToBeProcessed then begin
875	//kt if not FEditable then exit;
876	ToggleItalic;
877	Msg.Result := 1; //Handled
878	end;
879	Ord('Q') : if CtrlToBeProcessed then begin
880	//kt if not FEditable then exit;
881	Outdent;
882	Msg.Result := 1; //Handled
883	exit;
884	end;
885	Ord('W') : if CtrlToBeProcessed then begin
886	//kt if not FEditable then exit;
887	Indent;
888	Msg.Result := 1; //Handled
889	exit;
890	end;
891	Ord('D') : if CtrlToBeProcessed then begin
892	//kt if not FEditable then exit;
893	FontDialog;
894	Msg.Result := 1; //Handled
895	exit;
896	end;
897	{
898	Ord('.') : if CtrlToBeProcessed then begin
899	//kt if not FEditable then exit;
900	ToggleBullet;
901	Msg.Result := 1; //Handled
902	exit;
903	end;
904	Ord('N') : if CtrlToBeProcessed then begin
905	//kt if not FEditable then exit;
906	ToggleNumbering;
907	Msg.Result := 1; //Handled
908	exit;
909	end;
910	Ord(';') : if CtrlToBeProcessed then begin
911	//kt if not FEditable then exit;
912	TextForeColorDialog;
913	Msg.Result := 1; //Handled
914	exit;
915	end;
916	Ord('''') : if CtrlToBeProcessed then begin
917	//kt if not FEditable then exit;
918	TextBackColorDialog;
919	Msg.Result := 1; //Handled
920	exit;
921	end;
922	}
923	end; {case}
924	end;
925	WM_KEYUP : begin
926	case Msg.WParam of
927	VK_CONTROL : begin
928	CtrlToBeProcessed:=false;
929	Msg.Result := 1; //Handled
930	if CtrlReturnToBeProcessed then begin
931	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_RETURN, 0);
932	end;
933	exit;
934	end;
935	VK_SHIFT : begin
936	ShiftToBeProcessed:=false;
937	Msg.Result := 1; //Handled
938	exit;
939	end;
940
941	end; {case}
942	exit;
943	end;
944	end; {case}
945	end;
946
947	procedure THtmlObj.HandleBlur(Sender: TObject);
948	//kt added function
949	function RecentKeyPressed : boolean;
950	var NowTime : FILETIME; //kt
951	KeyTime,NowTime2 : LARGE_INTEGER;
952	Delta : int64;
953	begin
954	GetSystemTimeAsFileTime(NowTime);
955	NowTime2.LowPart := NowTime.dwLowDateTime;
956	NowTime2.HighPart := NowTime.dwHighDateTime;
957	KeyTime.LowPart := KeyPressTime.dwLowDateTime;
958	KeyTime.HighPart := KeyPressTime.dwHighDateTime;
959	Delta := floor( (NowTime2.QuadPart - KeyTime.QuadPart) / 100000);
960	Result := (Delta < 100) and (Delta > 0);
961	end;
962
963	begin
964	//kt Handle loss of focus when attempting to cursor above top line, or below bottom line.
965	if (not AllowNextBlur) and RecentKeyPressed then begin //kt entire block
966	SetFocusToDoc;
967	//beep(880,100);
968	KeyPressTime.dwLowDateTime := 0;
969	KeyPressTime.dwHighDateTime := 0;
970	exit;
971	end;
972	AllowNextBlur := false;
973	SetMsgActive(false);
974	end;
975
976	function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
977	begin
978	SetMsgActive(fGotFocus);
979	end;
980
981	function THtmlObj.GetActive : boolean;
982	begin
983	Result := TWinControl(Owner).Visible;
984	end;
985
986
987	initialization
988
989	finalization
990
991	end.
992

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

Context Navigation

source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/TMGHTML2.pas@ 1806

Download in other formats: