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

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;
[698]	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}
[698]	92	PopupMenu: TPopupMenu;
[541]	93	KeyStruck : boolean; // A VERY crude determiner as to if Modified.
	94	NextControl : TWinControl;
	95	PrevControl : TWinControl;
[698]	96	procedure SetMsgActive (Active : boolean);
	97	constructor Create(Owner:TControl; Application : TApplication);
[541]	98	destructor Destroy; override;
[698]	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;
	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
[793]	694	procedure THtmlObj.InsertHTMLAtCaret(HTMLText : AnsiString);
	695	var
	696	Range: IHTMLTxtRange;
	697	begin
	698	Range:= 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
[793]	765
	766	const
	767	FontSizes : array [0..6] of byte = (8,10,12,14,18,24,36);
	768
[541]	769	var i : Integer;
	770	WinControl : TWinControl;
[793]	771	TextSize : integer;
[541]	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;
[793]	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;
[541]	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;
[793]	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	}
[541]	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);
[654]	960	Result := (Delta < 100) and (Delta > 0);
[541]	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: