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

Last change on this file since 1802 was 793, checked in by Kevin Toppenberg, 14 years ago

update

File size: 32.6 KB
Line 
1unit TMGHTML2;
2
3(*
4NOTES: By Kevin Toppenberg, MD 5/27/09
5
6Code heavily modified from original code found at www.supermemo.com/source/
7Their notes (below) indicate that the code may be freely used.
8---------------
9This unit encapsulates SHDocVw.dll and MSHTML.dll functionality by subclassing
10THtmlEditorBrowser object as THtmlEditor object
11
12THtmlEditor was designed for easy use of HTML display and editing capacity in
13SuperMemo 2002 for Windows developed by SuperMemo R&D in Fall 2001.
14
15SuperMemo 2002 implements HTML-based incremental reading in which extensive HTML
16support is vital.
17
18Pieces of this units can be used by anyone in other Delphi applications that make
19use of HTML WYSIWYG interfaces made open by Microsoft.
20*)
21
22(*
23NOTICE: Also Derived from EmbeddedED. See notes in that code block.
24*)
25
26interface
27
28uses SysUtils, WinTypes, Dialogs, StdCtrls, Menus,
29 EmbeddedED,
30 ActiveX, MSHTMLEvents, SHDocVw, {MSHTML,} MSHTML_EWB,
31 AppEvnts, controls,
32 IeConst,Messages,Classes,Forms,Graphics;
33
34type
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
49type
50 // THtmlObj=class(TWebBrowser)
51 THtmlObj=class(TEmbeddedED)
52 private
53 CtrlToBeProcessed : boolean;
54 ShiftToBeProcessed : boolean;
55 CtrlReturnToBeProcessed: boolean;
56 Modified: boolean;
57 FOrigAppOnMessage : TMessageEvent;
58 FApplication : TApplication;
59 FActive : boolean;
60 FEditable: boolean;
61 ColorDialog: TColorDialog;
62 AllowNextBlur : boolean;
63 function GetHTMLText:string;
64 procedure SetHTMLText(HTML:String);
65 function GetText:string;
66 procedure SetText(HTML:string);
67 function GetEditableState : boolean;
68 procedure SetEditableState (EditOn : boolean);
69 procedure SetBackgroundColor(Color:TColor);
70 function GetBackgroundColor : TColor;
71 function ColorToMSHTMLStr(color : TColor) : string;
72 function MSHTMLStrToColor(MSHTMLColor : string) : TColor;
73 procedure SetTextForegroundColor(Color:TColor);
74 function GetTextForegroundColor : TColor;
75 procedure SetTextBackgroundColor(Color:TColor);
76 function GetTextBackgroundColor : TColor;
77 function GetFontSize : integer;
78 procedure SetFontSize (Size : integer);
79 function GetFontName : string;
80 procedure SetFontName (Name : string);
81 function GetSelText:string;
82 procedure SetSelText (HTMLText : string);
83 procedure ReassignKeyboardHandler(TurnOn : boolean);
84 procedure GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
85 procedure HandleBlur(Sender: TObject);
86 procedure SubMessageHandler(var Msg: TMessage); override;
87 function SubFocusHandler(fGotFocus: BOOL): HResult; override;
88 function GetActive : boolean;
89 {end private}
90 public
91 {end public}
92 PopupMenu: TPopupMenu;
93 KeyStruck : boolean; // A VERY crude determiner as to if Modified.
94 NextControl : TWinControl;
95 PrevControl : TWinControl;
96 procedure SetMsgActive (Active : boolean);
97 constructor Create(Owner:TControl; Application : TApplication);
98 destructor Destroy; override;
99 procedure Clear;
100 procedure ToggleBullet;
101 procedure ToggleItalic;
102 procedure ToggleBold;
103 procedure ToggleNumbering;
104 procedure ToggleUnderline;
105 procedure ToggleSubscript;
106 procedure ToggleSuperscript;
107 procedure Indent;
108 procedure Outdent;
109 procedure AlignLeft;
110 procedure AlignRight;
111 procedure AlignCenter;
112 procedure TextForeColorDialog;
113 procedure TextBackColorDialog;
114 procedure FontDialog;
115 function SelStart:integer;
116 function SelEnd:integer;
117 function SelLength:integer;
118 function GetTextRange:IHtmlTxtRange;
119 procedure ReplaceSelection(HTML:string);
120 procedure Loaded; Override;
121 function GetTextLen : integer;
122 function MoveCaretToEnd : boolean;
123 function MoveCaretToPos(ScreenPos: TPoint) : HRESULT; //kt added
124 procedure InsertHTMLAtCaret(HTMLText : AnsiString); //kt 4/21/10
125 procedure InsertTextAtCaret(Text : AnsiString); //Note: Text is NOT HTMLtext
126 property HTMLText:string read GetHTMLText write SetHTMLText;
127 property Text:string read GetText write SetText;
128 //property Active : boolean read FActive write SetMsgActive;
129 property Active : boolean read GetActive;
130 property Editable : boolean read GetEditableState write SetEditableState;
131 property BackgroundColor : TColor read GetBackgroundColor write SetBackgroundColor;
132 property FontSize : integer read GetFontSize write SetFontSize;
133 property FontName : string read GetFontName write SetFontName;
134 property SelText : string read GetSelText write SetSelText;
135 end;
136
137implementation
138
139
140uses
141 WinProcs,Variants,Clipbrd, StrUtils, Math,
142 Windows;
143
144const
145 FontScale=3;
146 MaxTextLength = 100;
147 nl = #13#10;
148
149procedure EError(EText : string; E : Exception);
150begin
151 MessageDlg(EText,mtError,[mbOK],0);
152end;
153
154
155constructor THtmlObj.Create(Owner:TControl; Application : TApplication);
156begin
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;
165end;
166
167destructor THtmlObj.Destroy;
168begin
169 SetMsgActive(false); //Turns off local OnMessage handling
170 inherited Destroy;
171end;
172
173procedure 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.
178begin
179 FActive := Active;
180 ReassignKeyboardHandler(FActive);
181end;
182
183procedure THtmlObj.SetHTMLText(Html : String);
184var //V : OleVariant;
185 V2 : variant;
186 body : IHTMLElement;
187 status : string;
188 temp : string;
189begin
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 *)
231end;
232
233
234function THtmlObj.GetHTMLText:string;
235var WS:WideString;
236 ch:WideChar;
237 n:integer;
238 w:word;
239 s:string;
240begin
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;
254end;
255
256function THtmlObj.GetText:string;
257var WS:WideString;
258 ch:WideChar;
259 n:integer;
260 w:word;
261 s:string;
262begin
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;
276end;
277
278procedure THtmlObj.SetText(HTML:string);
279begin
280 if (DOC=nil)or(DOC.body=nil) then SetHTMLText(HTML)
281 else DOC.body.innerHTML:=HTML;
282end;
283
284procedure THtmlObj.Clear;
285begin
286 //kt if IsDirty then
287 NewDocument;
288 KeyStruck := false;
289 //SetHTMLText('');
290end;
291
292function THtmlObj.GetEditableState : boolean;
293var mode : string;
294begin
295 mode := Doc.designMode;
296 result := (mode = 'On');
297end;
298
299procedure THtmlObj.SetEditableState(EditOn : boolean);
300var LastMode : string;
301 count : integer;
302begin
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;
332end;
333
334procedure THtmlObj.SetBackgroundColor(Color:TColor);
335begin
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);
341end;
342
343function THtmlObj.GetBackgroundColor : TColor;
344begin
345 Result := clBlack; //default;
346 if Doc=nil then exit;
347 if Doc.body=nil then exit;
348 Result := MSHTMLStrToColor(Doc.body.style.backgroundColor);
349end;
350
351function THtmlObj.ColorToMSHTMLStr(color : TColor) : string;
352//Note: TColor stores colors lo-byte --> hi-byte as RGB
353//Function returns '#RRGGBB'
354var tempColor : TMGColor;
355begin
356 tempColor.Color := color;
357 Result := '#'+
358 IntToHex(tempColor.RGBColor.R,2)+
359 IntToHex(tempColor.RGBColor.G,2)+
360 IntToHex(tempColor.RGBColor.B,2);
361end;
362
363function THtmlObj.MSHTMLStrToColor(MSHTMLColor : string) : TColor;
364//Function converts '#RRGGBB' -- TColor
365//Note: TColor stores colors lo-byte --> hi-byte as RGB
366var tempColor : TMGColor;
367 strHexRed,strHexGreen,strHexBlue : string[2];
368begin
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;
381end;
382
383procedure THtmlObj.ToggleBullet;
384begin
385 if DOC=nil then exit;
386 //SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
387 DOC.execCommand('InsertUnorderedList',false,null);
388 Modified:=true;
389end;
390
391procedure THtmlObj.ToggleItalic;
392begin
393 if DOC=nil then exit;
394 DOC.execCommand('Italic',false,null);
395 Modified:=true;
396end;
397
398procedure THtmlObj.ToggleBold;
399begin
400 if DOC=nil then exit;
401 DOC.execCommand('Bold',false,null);
402 Modified:=true;
403end;
404
405procedure THtmlObj.ToggleNumbering;
406begin
407 if DOC=nil then exit;
408 DOC.execCommand('InsertOrderedList',false,null);
409// SpecialCommand(IDM_ORDERLIST,false,true,false,Null);
410 Modified:=true;
411end;
412
413procedure THtmlObj.ToggleUnderline;
414begin
415 if DOC=nil then exit;
416 DOC.execCommand('Underline',false,null);
417 Modified:=true;
418end;
419
420procedure THtmlObj.ToggleSubscript;
421begin
422 if DOC=nil then exit;
423 DOC.execCommand('Subscript',False,0);
424 Modified:=true;
425end;
426
427procedure THtmlObj.ToggleSuperscript;
428begin
429 if DOC=nil then exit;
430 DOC.execCommand('Superscript',False,0);
431 Modified:=true;
432end;
433
434
435procedure THtmlObj.Indent;
436begin
437 if DOC=nil then exit;
438 DOC.ExecCommand('Indent',false,0);
439 Modified:=true;
440end;
441
442procedure THtmlObj.Outdent;
443begin
444 if DOC=nil then exit;
445 DOC.ExecCommand('Outdent',false,0);
446 Modified:=true;
447end;
448
449
450procedure THtmlObj.AlignLeft;
451begin
452 if DOC=nil then exit;
453 DOC.ExecCommand('JustifyLeft',false,0);
454 Modified:=true;
455end;
456
457procedure THtmlObj.AlignRight;
458begin
459 if DOC=nil then exit;
460 DOC.ExecCommand('JustifyRight',false,0);
461 Modified:=true;
462end;
463
464procedure THtmlObj.AlignCenter;
465begin
466 if DOC=nil then exit;
467 DOC.ExecCommand('JustifyCenter',false,0);
468 Modified:=true;
469end;
470
471procedure THtmlObj.TextForeColorDialog;
472begin
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;
480end;
481
482procedure THtmlObj.TextBackColorDialog;
483begin
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;
491end;
492
493procedure THtmlObj.SetTextForegroundColor(Color:TColor);
494begin
495 if DOC=nil then exit;
496 DOC.ExecCommand('ForeColor',false,Color);
497 Modified:=true;
498end;
499
500function THtmlObj.GetTextForegroundColor:TColor;
501var Background : OleVariant;
502 vt : TVarType;
503begin
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;
513end;
514
515procedure THtmlObj.SetTextBackgroundColor(Color:TColor);
516begin
517 if DOC=nil then exit;
518 DOC.ExecCommand('BackColor',false,Color);
519 Modified:=true;
520end;
521
522function THtmlObj.GetTextBackgroundColor:TColor;
523var Background : OleVariant;
524 vt : TVarType;
525begin
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;
535end;
536
537procedure THtmlObj.FontDialog;
538begin
539 DoCommand(IDM_FONT);
540 Modified:=true;
541end;
542
543function THtmlObj.GetFontSize : integer;
544var FontSize : OleVariant;
545 vt : TVarType;
546
547begin
548 FontSize:=Doc.queryCommandValue('FontSize');
549 vt:=varType(FontSize);
550 if vt<>varNull then Result := FontSize*FontScale
551 else Result :=12*FontScale; //kt
552end;
553
554procedure THtmlObj.SetFontSize (Size : integer);
555begin
556 if Doc=nil then exit;
557 Doc.ExecCommand('FontSize', false, Size div FontScale);
558end;
559
560function THtmlObj.GetFontName : string;
561var FontName :OleVariant;
562 vt : TVarType;
563begin
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
569end;
570
571procedure THtmlObj.SetFontName (Name : string);
572begin
573 if DOC=nil then exit;
574 DOC.ExecCommand('FontName', false, Name);
575end;
576
577function THtmlObj.SelStart:integer;
578var TextRange:IHtmlTxtRange;
579begin
580 Result:=0;
581 TextRange:=GetTextRange;
582 if TextRange=nil then exit;
583 Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
584end;
585
586function THtmlObj.SelEnd:integer;
587var TextRange:IHtmlTxtRange;
588begin
589 Result:=0;
590 TextRange:=GetTextRange;
591 if TextRange=nil then exit;
592 Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
593end;
594
595function THtmlObj.SelLength:integer;
596begin
597 Result:=SelEnd-SelStart;
598end;
599
600function THtmlObj.GetTextRange:IHtmlTxtRange;
601begin
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;
621end;
622
623function THtmlObj.GetSelText:string;
624var TextRange:IHtmlTxtRange;
625begin
626 Result:='';
627 TextRange:=GetTextRange;
628 if TextRange=nil then
629 exit;
630 Result:=TextRange.text;
631end;
632
633procedure THtmlObj.SetSelText (HTMLText : string);
634begin
635 ReplaceSelection(HTMLText);
636end;
637
638procedure THtmlObj.ReplaceSelection(HTML:string);
639var TextRange:IHtmlTxtRange;
640begin
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;
654end;
655
656
657function THtmlObj.MoveCaretToEnd : boolean;
658//kt added
659var //TextRange:IHtmlTxtRange;
660 count : integer;
661begin
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 }
682end;
683
684function THtmlObj.MoveCaretToPos(ScreenPos: TPoint) : HRESULT;
685//kt added entire function
686var OutTemp : DWORD;
687begin
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));
692end;
693
694procedure THtmlObj.InsertHTMLAtCaret(HTMLText : AnsiString);
695var
696 Range: IHTMLTxtRange;
697begin
698 Range:= GetTextRange;
699 Range.pasteHTML(HTMLText);
700end;
701
702procedure THtmlObj.InsertTextAtCaret(Text : AnsiString);
703//kt added. Note: inserts external format (not HTML markup)
704var P : PWideChar;
705begin
706 P := StringToOleStr(Text);
707 FCaret.InsertText(P,Length(Text))
708end;
709
710
711procedure THtmlObj.Loaded;
712begin
713 inherited Loaded;
714end;
715
716function THtmlObj.GetTextLen : integer;
717begin
718 Result := Length(GetText);
719end;
720
721
722procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
723{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
724begin
725 if TurnOn then begin
726 FApplication.OnMessage := GlobalMsgHandler;
727 end else begin
728 FApplication.OnMessage := FOrigAppOnMessage;
729 end;
730end;
731
732procedure 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. }
739var
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
751begin
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;
760end;
761
762
763procedure THtmlObj.SubMessageHandler(var Msg: TMessage);
764//Called from parent's EDMessageHandler, or from GlobalMsgHandler
765
766const
767 FontSizes : array [0..6] of byte = (8,10,12,14,18,24,36);
768
769var i : Integer;
770 WinControl : TWinControl;
771 TextSize : integer;
772
773begin
774 Msg.Result := 0; //default to not handled
775 if not ((Msg.Msg=WM_KEYDOWN) or
776 (Msg.Msg=WM_KEYUP) or
777 (Msg.Msg=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
778 case Msg.Msg of
779 WM_RBUTTONUP : begin
780 if CtrlToBeProcessed then begin
781 CtrlToBeProcessed := false;
782 exit; //Ctrl-right click is ignored
783 end;
784 if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
785 Msg.Result := 1; //Handled
786 exit;
787 end;
788 WM_KEYDOWN : begin
789 GetSystemTimeAsFileTime(KeyPressTime);
790 KeyStruck := true;
791 //beep(200,50);
792 case Msg.WParam of
793 VK_ESCAPE : begin
794 if Assigned(PrevControl) then begin
795 AllowNextBlur := true;
796 PrevControl.SetFocus;
797 end;
798 end;
799 VK_CONTROL : begin
800 CtrlToBeProcessed:=true;
801 Msg.Result := 1; //Handled
802 exit;
803 end;
804 VK_SHIFT : begin
805 ShiftToBeProcessed:=true;
806 Msg.Result := 1; //Handled
807 exit;
808 end;
809 VK_TAB : begin
810 if (ShiftToBeProcessed and CtrlToBeProcessed) then begin
811 //This isn't working for some reason...
812 for i := 0 to 5 do begin
813 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_LEFT, 0);
814 end;
815 ShiftToBeProcessed := false;
816 CtrlToBeProcessed := false;
817 end else if ShiftToBeProcessed then begin
818 if Assigned(PrevControl) then begin
819 AllowNextBlur := true;
820 PrevControl.SetFocus;
821 end;
822 ShiftToBeProcessed := false;
823 end else if CtrlToBeProcessed then begin
824 if Assigned(NextControl) then begin
825 AllowNextBlur := true;
826 NextControl.SetFocus;
827 end;
828 CtrltoBeProcessed := false;
829 end else begin
830 for i := 0 to 5 do begin
831 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_SPACE, 0);
832 end;
833 end;
834 Msg.Result := 1; //Handled
835 end;
836 $31..$38 : begin
837 if CtrlToBeProcessed = true then begin
838 TextSize := Msg.WParam-$31;
839 if (TextSize >= 0) and (TextSize <=6 ) then begin
840 SetFontSize(FontSizes[TextSize]);
841 CtrlToBeProcessed := False;
842 end;
843 end;
844 end;
845 {
846 VK_RETURN : if CtrlReturnToBeProcessed then begin
847 Msg.Result := 1; //Handled
848 CtrlReturnToBeProcessed := false;
849 end else if CtrlToBeProcessed then begin
850 Msg.Result := 1; //Handled
851 CtrlToBeProcessed := False;
852 CtrlReturnToBeProcessed := true;
853 //PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
854 end else if ShiftToBeProcessed=false then begin
855 //kt if not FEditable then exit;
856 keybd_event(VK_SHIFT,0,0,0);
857 keybd_event(VK_RETURN,0,0,0);
858 keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
859 Msg.Result := 1; //Handled
860 end;
861 }
862 Ord('B') : if CtrlToBeProcessed then begin
863 //kt if not FEditable then exit;
864 ToggleBold;
865 Msg.Result := 1; //Handled
866 exit;
867 end;
868 Ord('U') : if CtrlToBeProcessed then begin
869 //kt if not FEditable then exit;
870 ToggleUnderline;
871 Msg.Result := 1; //Handled
872 exit;
873 end;
874 Ord('I') : if CtrlToBeProcessed then begin
875 //kt if not FEditable then exit;
876 ToggleItalic;
877 Msg.Result := 1; //Handled
878 end;
879 Ord('Q') : if CtrlToBeProcessed then begin
880 //kt if not FEditable then exit;
881 Outdent;
882 Msg.Result := 1; //Handled
883 exit;
884 end;
885 Ord('W') : if CtrlToBeProcessed then begin
886 //kt if not FEditable then exit;
887 Indent;
888 Msg.Result := 1; //Handled
889 exit;
890 end;
891 Ord('D') : if CtrlToBeProcessed then begin
892 //kt if not FEditable then exit;
893 FontDialog;
894 Msg.Result := 1; //Handled
895 exit;
896 end;
897 {
898 Ord('.') : if CtrlToBeProcessed then begin
899 //kt if not FEditable then exit;
900 ToggleBullet;
901 Msg.Result := 1; //Handled
902 exit;
903 end;
904 Ord('N') : if CtrlToBeProcessed then begin
905 //kt if not FEditable then exit;
906 ToggleNumbering;
907 Msg.Result := 1; //Handled
908 exit;
909 end;
910 Ord(';') : if CtrlToBeProcessed then begin
911 //kt if not FEditable then exit;
912 TextForeColorDialog;
913 Msg.Result := 1; //Handled
914 exit;
915 end;
916 Ord('''') : if CtrlToBeProcessed then begin
917 //kt if not FEditable then exit;
918 TextBackColorDialog;
919 Msg.Result := 1; //Handled
920 exit;
921 end;
922 }
923 end; {case}
924 end;
925 WM_KEYUP : begin
926 case Msg.WParam of
927 VK_CONTROL : begin
928 CtrlToBeProcessed:=false;
929 Msg.Result := 1; //Handled
930 if CtrlReturnToBeProcessed then begin
931 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_RETURN, 0);
932 end;
933 exit;
934 end;
935 VK_SHIFT : begin
936 ShiftToBeProcessed:=false;
937 Msg.Result := 1; //Handled
938 exit;
939 end;
940
941 end; {case}
942 exit;
943 end;
944 end; {case}
945end;
946
947procedure THtmlObj.HandleBlur(Sender: TObject);
948//kt added function
949 function RecentKeyPressed : boolean;
950 var NowTime : FILETIME; //kt
951 KeyTime,NowTime2 : LARGE_INTEGER;
952 Delta : int64;
953 begin
954 GetSystemTimeAsFileTime(NowTime);
955 NowTime2.LowPart := NowTime.dwLowDateTime;
956 NowTime2.HighPart := NowTime.dwHighDateTime;
957 KeyTime.LowPart := KeyPressTime.dwLowDateTime;
958 KeyTime.HighPart := KeyPressTime.dwHighDateTime;
959 Delta := floor( (NowTime2.QuadPart - KeyTime.QuadPart) / 100000);
960 Result := (Delta < 100) and (Delta > 0);
961 end;
962
963begin
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);
974end;
975
976function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
977begin
978 SetMsgActive(fGotFocus);
979end;
980
981function THtmlObj.GetActive : boolean;
982begin
983 Result := TWinControl(Owner).Visible;
984end;
985
986
987initialization
988
989finalization
990
991end.
992
Note: See TracBrowser for help on using the repository browser.