Context Navigation

TMGHTML2.~pas@ 656

Last change on this file since 656 was 654, checked in by Kevin Toppenberg, 15 years ago
Added HTML templating
File size: 29.2 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	if not assigned (FTMGDisplayPointer) then begin
662	Result := false;
663	exit;
664	end;
665	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_BottomOfWindow,0));
666	count := 0;
667	repeat
668	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_NextLine,-1));
669	inc (count);
670	until (Result = false) or (count > 500);
671	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_CurrentLineEnd,0));
672	Result:=(S_OK = FCaret.MoveCaretToPointer(FTMGDisplayPointer,
673	integer(FALSE),
674	CARET_DIRECTION_SAME));
675	{
676	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
677	SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
678	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
679	SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
680	}
681	end;
682
683	function THtmlObj.MoveCaretToPos(ScreenPos: TPoint) : HRESULT;
684	//kt added entire function
685	var OutTemp : DWORD;
686	begin
687	if not assigned (FTMGDisplayPointer) then exit;
688	FTMGDisplayPointer.moveToPoint(ScreenPos, COORD_SYSTEM_GLOBAL, nil, HT_OPT_AllowAfterEOL, OutTemp);
689	Result := FCaret.MoveCaretToPointer(FTMGDisplayPointer,Integer(True),CARET_DIRECTION_INDETERMINATE);
690	FCaret.Show(Integer(True));
691	end;
692
693	procedure THtmlObj.InsertTextAtCaret(Text : AnsiString);
694	//kt added. Note: inserts external format (not HTML markup)
695	var P : PWideChar;
696	begin
697	P := StringToOleStr(Text);
698	FCaret.InsertText(P,Length(Text))
699	end;
700
701
702	procedure THtmlObj.Loaded;
703	begin
704	inherited Loaded;
705	end;
706
707	function THtmlObj.GetTextLen : integer;
708	begin
709	Result := Length(GetText);
710	end;
711
712
713	procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
714	{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
715	begin
716	if TurnOn then begin
717	FApplication.OnMessage := GlobalMsgHandler;
718	end else begin
719	FApplication.OnMessage := FOrigAppOnMessage;
720	end;
721	end;
722
723	procedure THtmlObj.GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
724	{NOTE: This message handler will receive ALL messages directed to CPRS. I
725	have to do this, because something is filtering messages before they
726	get to this THTMLObj object. My goal is to do as little here as possible,
727	and let the OnMessage for THTMLObj (found in EmbeddedED) take care of the rest.
728	NOTE: This should get activated by OnFocus for object, and deactivated
729	by OnBlur, so it actually should only get messages when focused. }
730	var
731	i : Integer;
732	NewMsg : TMessage;
733
734	function TransformMessage (WinMsg : TMsg) : TMessage;
735	begin
736	Result.Msg := WinMsg.message;
737	Result.WParam := WinMsg.wParam;
738	Result.LParam := WinMsg.lParam;
739	Result.Result := 0;
740	end;
741
742	begin
743	Handled:=false; //default to not handled
744	if (Msg.Message=WM_KEYDOWN) then begin
745	if (Msg.WParam=VK_UP) or (Msg.WParam=VK_DOWN) or (Msg.WParam=VK_TAB) then begin
746	NewMsg := TransformMessage(Msg);
747	SubMessageHandler(NewMsg);
748	Handled := (NewMsg.Result = 1);
749	end;
750	end;
751	end;
752
753
754	procedure THtmlObj.SubMessageHandler(var Msg: TMessage);
755	//Called from parent's EDMessageHandler, or from GlobalMsgHandler
756	var i : Integer;
757	WinControl : TWinControl;
758
759	begin
760	Msg.Result := 0; //default to not handled
761	if not ((Msg.Msg=WM_KEYDOWN) or
762	(Msg.Msg=WM_KEYUP) or
763	(Msg.Msg=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
764	case Msg.Msg of
765	WM_RBUTTONUP : begin
766	if CtrlToBeProcessed then begin
767	CtrlToBeProcessed := false;
768	exit; //Ctrl-right click is ignored
769	end;
770	if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
771	Msg.Result := 1; //Handled
772	exit;
773	end;
774	WM_KEYDOWN : begin
775	GetSystemTimeAsFileTime(KeyPressTime);
776	KeyStruck := true;
777	//beep(200,50);
778	case Msg.WParam of
779	VK_ESCAPE : begin
780	if Assigned(PrevControl) then begin
781	AllowNextBlur := true;
782	PrevControl.SetFocus;
783	end;
784	end;
785	VK_CONTROL : begin
786	CtrlToBeProcessed:=true;
787	Msg.Result := 1; //Handled
788	exit;
789	end;
790	VK_SHIFT : begin
791	ShiftToBeProcessed:=true;
792	Msg.Result := 1; //Handled
793	exit;
794	end;
795	VK_TAB : begin
796	if (ShiftToBeProcessed and CtrlToBeProcessed) then begin
797	//This isn't working for some reason...
798	for i := 0 to 5 do begin
799	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_LEFT, 0);
800	end;
801	ShiftToBeProcessed := false;
802	CtrlToBeProcessed := false;
803	end else if ShiftToBeProcessed then begin
804	if Assigned(PrevControl) then begin
805	AllowNextBlur := true;
806	PrevControl.SetFocus;
807	end;
808	ShiftToBeProcessed := false;
809	end else if CtrlToBeProcessed then begin
810	if Assigned(NextControl) then begin
811	AllowNextBlur := true;
812	NextControl.SetFocus;
813	end;
814	CtrltoBeProcessed := false;
815	end else begin
816	for i := 0 to 5 do begin
817	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_SPACE, 0);
818	end;
819	end;
820	Msg.Result := 1; //Handled
821	end;
822	{
823	VK_RETURN : if CtrlReturnToBeProcessed then begin
824	Msg.Result := 1; //Handled
825	CtrlReturnToBeProcessed := false;
826	end else if CtrlToBeProcessed then begin
827	Msg.Result := 1; //Handled
828	CtrlToBeProcessed := False;
829	CtrlReturnToBeProcessed := true;
830	//PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
831	end else if ShiftToBeProcessed=false then begin
832	//kt if not FEditable then exit;
833	keybd_event(VK_SHIFT,0,0,0);
834	keybd_event(VK_RETURN,0,0,0);
835	keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
836	Msg.Result := 1; //Handled
837	end;
838	}
839	Ord('B') : if CtrlToBeProcessed then begin
840	//kt if not FEditable then exit;
841	ToggleBold;
842	Msg.Result := 1; //Handled
843	exit;
844	end;
845	Ord('U') : if CtrlToBeProcessed then begin
846	//kt if not FEditable then exit;
847	ToggleUnderline;
848	Msg.Result := 1; //Handled
849	exit;
850	end;
851	Ord('I') : if CtrlToBeProcessed then begin
852	//kt if not FEditable then exit;
853	ToggleItalic;
854	Msg.Result := 1; //Handled
855	end;
856	end; {case}
857	end;
858	WM_KEYUP : begin
859	case Msg.WParam of
860	VK_CONTROL : begin
861	CtrlToBeProcessed:=false;
862	Msg.Result := 1; //Handled
863	if CtrlReturnToBeProcessed then begin
864	PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_RETURN, 0);
865	end;
866	exit;
867	end;
868	VK_SHIFT : begin
869	ShiftToBeProcessed:=false;
870	Msg.Result := 1; //Handled
871	exit;
872	end;
873
874	end; {case}
875	exit;
876	end;
877	end; {case}
878	end;
879
880	procedure THtmlObj.HandleBlur(Sender: TObject);
881	//kt added function
882	function RecentKeyPressed : boolean;
883	var NowTime : FILETIME; //kt
884	KeyTime,NowTime2 : LARGE_INTEGER;
885	Delta : int64;
886	begin
887	GetSystemTimeAsFileTime(NowTime);
888	NowTime2.LowPart := NowTime.dwLowDateTime;
889	NowTime2.HighPart := NowTime.dwHighDateTime;
890	KeyTime.LowPart := KeyPressTime.dwLowDateTime;
891	KeyTime.HighPart := KeyPressTime.dwHighDateTime;
892	Delta := floor( (NowTime2.QuadPart - KeyTime.QuadPart) / 100000);
893	Result := (Delta < 100);
894	end;
895
896	begin
897	//kt Handle loss of focus when attempting to cursor above top line, or below bottom line.
898	if (not AllowNextBlur) and RecentKeyPressed then begin //kt entire block
899	SetFocusToDoc;
900	//beep(880,100);
901	KeyPressTime.dwLowDateTime := 0;
902	KeyPressTime.dwHighDateTime := 0;
903	exit;
904	end;
905	AllowNextBlur := false;
906	SetMsgActive(false);
907	end;
908
909	function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
910	begin
911	SetMsgActive(fGotFocus);
912	end;
913
914	function THtmlObj.GetActive : boolean;
915	begin
916	Result := TWinControl(Owner).Visible;
917	end;
918
919
920	initialization
921
922	finalization
923
924	end.
925

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

Download in other formats:

Original Format