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

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

update

File size: 29.5 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:= Self.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
765var i : Integer;
766 WinControl : TWinControl;
767
768begin
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}
887end;
888
889procedure 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);
902 Result := (Delta < 100) and (Delta > 0);
903 end;
904
905begin
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);
916end;
917
918function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
919begin
920 SetMsgActive(fGotFocus);
921end;
922
923function THtmlObj.GetActive : boolean;
924begin
925 Result := TWinControl(Owner).Visible;
926end;
927
928
929initialization
930
931finalization
932
933end.
934
Note: See TracBrowser for help on using the repository browser.