Context Navigation

TMGHTML2.~pas@ 673

Last change on this file since 673 was 654, checked in by Kevin Toppenberg, 15 years ago
Added HTML templating
File size: 29.2 KB

Rev	Line
[541]	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;
[654]	657	//kt added
[541]	658	var //TextRange:IHtmlTxtRange;
	659	count : integer;
	660	begin
[654]	661	if not assigned (FTMGDisplayPointer) then begin
	662	Result := false;
	663	exit;
	664	end;
[541]	665	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_BottomOfWindow,0));
	666	count := 0;
[654]	667	repeat
[541]	668	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_NextLine,-1));
	669	inc (count);
	670	until (Result = false) or (count > 500);
[654]	671	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_CurrentLineEnd,0));
[541]	672	Result:=(S_OK = FCaret.MoveCaretToPointer(FTMGDisplayPointer,
	673	integer(FALSE),
	674	CARET_DIRECTION_SAME));
	675	{
[654]	676	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
[541]	677	SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
[654]	678	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
[541]	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