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: 29.5 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;
[793]	62	AllowNextBlur : boolean;
[541]	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}
[793]	92	PopupMenu: TPopupMenu;
[541]	93	KeyStruck : boolean; // A VERY crude determiner as to if Modified.
	94	NextControl : TWinControl;
	95	PrevControl : TWinControl;
[793]	96	procedure SetMsgActive (Active : boolean);
	97	constructor Create(Owner:TControl; Application : TApplication);
[541]	98	destructor Destroy; override;
[793]	99	procedure Clear;
[541]	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
[793]	124	procedure InsertHTMLAtCaret(HTMLText : AnsiString); //kt 4/21/10
[541]	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;
[654]	658	//kt added
[541]	659	var //TextRange:IHtmlTxtRange;
	660	count : integer;
	661	begin
[654]	662	if not assigned (FTMGDisplayPointer) then begin
	663	Result := false;
	664	exit;
	665	end;
[541]	666	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_BottomOfWindow,0));
	667	count := 0;
[654]	668	repeat
[541]	669	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_NextLine,-1));
	670	inc (count);
	671	until (Result = false) or (count > 500);
[654]	672	Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_CurrentLineEnd,0));
[541]	673	Result:=(S_OK = FCaret.MoveCaretToPointer(FTMGDisplayPointer,
	674	integer(FALSE),
	675	CARET_DIRECTION_SAME));
	676	{
[654]	677	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
[541]	678	SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
[654]	679	SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
[541]	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
[793]	694	procedure THtmlObj.InsertHTMLAtCaret(HTMLText : AnsiString);
	695	var
	696	Range: IHTMLTxtRange;
	697	begin
	698	Range:= Self.GetTextRange;
	699	Range.pasteHTML(HTMLText);
	700	end;
	701
[541]	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);
[698]	902	Result := (Delta < 100) and (Delta > 0);
[541]	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