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

Last change on this file since 581 was 541, checked in by Kevin Toppenberg, 15 years ago

TMG Ver 1.1 Added HTML Support, better demographics editing
File size: 29.1 KB
RevLine 
[541]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 procedure SetMsgActive (Active : boolean);
64 function GetHTMLText:string;
65 procedure SetHTMLText(HTML:String);
66 function GetText:string;
67 procedure SetText(HTML:string);
68 function GetEditableState : boolean;
69 procedure SetEditableState (EditOn : boolean);
70 procedure SetBackgroundColor(Color:TColor);
71 function GetBackgroundColor : TColor;
72 function ColorToMSHTMLStr(color : TColor) : string;
73 function MSHTMLStrToColor(MSHTMLColor : string) : TColor;
74 procedure SetTextForegroundColor(Color:TColor);
75 function GetTextForegroundColor : TColor;
76 procedure SetTextBackgroundColor(Color:TColor);
77 function GetTextBackgroundColor : TColor;
78 function GetFontSize : integer;
79 procedure SetFontSize (Size : integer);
80 function GetFontName : string;
81 procedure SetFontName (Name : string);
82 function GetSelText:string;
83 procedure SetSelText (HTMLText : string);
84 procedure ReassignKeyboardHandler(TurnOn : boolean);
85 procedure GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
86 procedure HandleBlur(Sender: TObject);
87 procedure SubMessageHandler(var Msg: TMessage); override;
88 function SubFocusHandler(fGotFocus: BOOL): HResult; override;
89 function GetActive : boolean;
90 {end private}
91 public
92 {end public}
93 PopupMenu: TPopupMenu;
94 KeyStruck : boolean; // A VERY crude determiner as to if Modified.
95 NextControl : TWinControl;
96 PrevControl : TWinControl;
97 constructor Create(Owner:TControl; Application : TApplication);
98 destructor Destroy; override;
99 procedure Clear;
100 procedure ToggleBullet;
101 procedure ToggleItalic;
102 procedure ToggleBold;
103 procedure ToggleNumbering;
104 procedure ToggleUnderline;
105 procedure ToggleSubscript;
106 procedure ToggleSuperscript;
107 procedure Indent;
108 procedure Outdent;
109 procedure AlignLeft;
110 procedure AlignRight;
111 procedure AlignCenter;
112 procedure TextForeColorDialog;
113 procedure TextBackColorDialog;
114 procedure FontDialog;
115 function SelStart:integer;
116 function SelEnd:integer;
117 function SelLength:integer;
118 function GetTextRange:IHtmlTxtRange;
119 procedure ReplaceSelection(HTML:string);
120 procedure Loaded; Override;
121 function GetTextLen : integer;
122 function MoveCaretToEnd : boolean;
123 function MoveCaretToPos(ScreenPos: TPoint) : HRESULT; //kt added
124 procedure InsertTextAtCaret(Text : AnsiString); //Note: Text is NOT HTMLtext
125 property HTMLText:string read GetHTMLText write SetHTMLText;
126 property Text:string read GetText write SetText;
127 //property Active : boolean read FActive write SetMsgActive;
128 property Active : boolean read GetActive;
129 property Editable : boolean read GetEditableState write SetEditableState;
130 property BackgroundColor : TColor read GetBackgroundColor write SetBackgroundColor;
131 property FontSize : integer read GetFontSize write SetFontSize;
132 property FontName : string read GetFontName write SetFontName;
133 property SelText : string read GetSelText write SetSelText;
134 end;
135
136implementation
137
138
139uses
140 WinProcs,Variants,Clipbrd, StrUtils, Math,
141 Windows;
142
143const
144 FontScale=3;
145 MaxTextLength = 100;
146 nl = #13#10;
147
148procedure EError(EText : string; E : Exception);
149begin
150 MessageDlg(EText,mtError,[mbOK],0);
151end;
152
153
154constructor THtmlObj.Create(Owner:TControl; Application : TApplication);
155begin
156 inherited Create(Owner); //Note: Owner should be a descendant of TControl;
157 FApplication := Application;
158 FOrigAppOnMessage := Application.OnMessage;
159 OnBlur := HandleBlur;
160 AllowNextBlur := false;
161 KeyStruck := false;
162 NextControl := nil;
163 PrevControl := nil;
164end;
165
166destructor THtmlObj.Destroy;
167begin
168 SetMsgActive(false); //Turns off local OnMessage handling
169 inherited Destroy;
170end;
171
172procedure THtmlObj.SetMsgActive (Active : boolean);
173//NOTE: This object grabs the OnMessage for the entire application, so that
174// it can intercept the right-click. As a result, the object needs a
175// way that it can turn off this feature when it is covered up by other
176// windows application subwindows etc. This function provides this.
177begin
178 FActive := Active;
179 ReassignKeyboardHandler(FActive);
180end;
181
182procedure THtmlObj.SetHTMLText(Html : String);
183var //V : OleVariant;
184 V2 : variant;
185 body : IHTMLElement;
186 status : string;
187 temp : string;
188begin
189 DocumentHTML := Html;
190 exit; //kt
191 (*
192 try
193 Stop;
194 if Doc =nil then exit;
195 body := Doc.body;
196
197 if UpperCase(Doc.designMode) <> 'ON' then begin
198 Doc.designMode := 'on';
199 repeat //NOTE: potential endless loop. Perhaps loop only status='loading'?
200 status := Doc.readyState;
201 {Possible status values:
202 uninitialized -- Object is not initialized with data.
203 loading -- Object is loading its data.
204 loaded -- Object has finished loading its data.
205 interactive -- User can interact with the object even though it is not fully loaded.
206 complete -- Object is completely initialized. }
207 if status <> 'complete' then FApplication.ProcessMessages;
208 until (status = 'complete') or (status='interactive') or (status='loaded');
209 end;
210 body := Doc.body;
211 if (body = nil) then begin //Do so stuff to get IE to make a 'body'.
212 V2 := VarArrayCreate([0, 0], VarVariant);
213 V2[0] := ' '; //Html;
214 Doc.Write(PSafeArray(System.TVarData(V2).VArray));
215 body := Doc.body;
216 Doc.close;
217 repeat
218 status := Doc.readyState; //For possible status values, see above)
219 if status <> 'complete' then FApplication.ProcessMessages;
220 until (status = 'complete') or (status='interactive') or (status='loaded');
221 body := Doc.body;
222 end;
223 body.innerHTML := Html;
224 temp := body.innerHTML; //to test if it was set or not...
225 Modified:=true;
226 except
227 on E:Exception do EError('Error setting HTML text',E);
228 end;
229 *)
230end;
231
232
233function THtmlObj.GetHTMLText:string;
234var WS:WideString;
235 ch:WideChar;
236 n:integer;
237 w:word;
238 s:string;
239begin
240 //Result:=DocumentHTML;
241 Result:='';
242 if Doc=nil then exit;
243 WS:=Doc.body.innerHTML;
244 for n:=1 to length(WS) do begin
245 ch := WS[n];
246 w := word(ch);
247 if w>255 then begin
248 s:=IntToStr(w);
249 s:='&#'+s+';';
250 end else s:=ch;
251 Result:=Result+s;
252 end;
253end;
254
255function THtmlObj.GetText:string;
256var WS:WideString;
257 ch:WideChar;
258 n:integer;
259 w:word;
260 s:string;
261begin
262 Result:='';
263 if DOC=nil then exit;
264 WS:=Doc.body.innerText;
265 for n:=1 to length(WS) do begin
266 ch:=WS[n];
267 w:=word(ch);
268 if w>255 then begin
269 w:=(w mod 256)+48;
270 s:=IntToStr(w);
271 s:=char(w);
272 end else s:=ch;
273 Result:=Result+s;
274 end;
275end;
276
277procedure THtmlObj.SetText(HTML:string);
278begin
279 if (DOC=nil)or(DOC.body=nil) then SetHTMLText(HTML)
280 else DOC.body.innerHTML:=HTML;
281end;
282
283procedure THtmlObj.Clear;
284begin
285 //kt if IsDirty then
286 NewDocument;
287 KeyStruck := false;
288 //SetHTMLText('');
289end;
290
291function THtmlObj.GetEditableState : boolean;
292var mode : string;
293begin
294 mode := Doc.designMode;
295 result := (mode = 'On');
296end;
297
298procedure THtmlObj.SetEditableState(EditOn : boolean);
299var LastMode : string;
300 count : integer;
301begin
302 LastMode := 'Inherit';
303 try
304 count := 0;
305 repeat
306 inc (count);
307 if Doc = nil then begin
308 FApplication.ProcessMessages;
309 Sleep (100);
310 continue;
311 end else if Doc.body = nil then begin
312 FApplication.ProcessMessages;
313 Sleep (100);
314 continue;
315 end;
316 if EditOn then begin
317 Doc.body.setAttribute('contentEditable','true',0);
318 Doc.designMode := 'On'; //kt
319 FEditable:=true;
320 //SetFocus;
321 end else begin
322 Doc.body.setAttribute('contentEditable','false',0);
323 Doc.designMode := 'Off'; //kt
324 FEditable:=false;
325 end;
326 LastMode := Doc.designMode;
327 until (LastMode <> 'Inherit') or (count > 20);
328 except
329 on E:Exception do EError('Error switching into HTML editing state',E);
330 end;
331end;
332
333procedure THtmlObj.SetBackgroundColor(Color:TColor);
334begin
335 if Doc=nil then exit;
336 //WaitLoad(true); //kt
337 WaitForDocComplete;
338 if Doc.body=nil then exit;
339 Doc.body.style.backgroundColor := ColorToMSHTMLStr(Color);
340end;
341
342function THtmlObj.GetBackgroundColor : TColor;
343begin
344 Result := clBlack; //default;
345 if Doc=nil then exit;
346 if Doc.body=nil then exit;
347 Result := MSHTMLStrToColor(Doc.body.style.backgroundColor);
348end;
349
350function THtmlObj.ColorToMSHTMLStr(color : TColor) : string;
351//Note: TColor stores colors lo-byte --> hi-byte as RGB
352//Function returns '#RRGGBB'
353var tempColor : TMGColor;
354begin
355 tempColor.Color := color;
356 Result := '#'+
357 IntToHex(tempColor.RGBColor.R,2)+
358 IntToHex(tempColor.RGBColor.G,2)+
359 IntToHex(tempColor.RGBColor.B,2);
360end;
361
362function THtmlObj.MSHTMLStrToColor(MSHTMLColor : string) : TColor;
363//Function converts '#RRGGBB' -- TColor
364//Note: TColor stores colors lo-byte --> hi-byte as RGB
365var tempColor : TMGColor;
366 strHexRed,strHexGreen,strHexBlue : string[2];
367begin
368 Result := clBlack; //FIX!!!! IMPLEMENT LATER...
369 if Pos('#',MSHTMLColor)=1 then begin
370 // MSHTMLColor := MidStr(MSHTMLColor,2,99);
371 strHexRed := MidStr(MSHTMLColor,2,2);
372 strHexGreen := MidStr(MSHTMLColor,4,2);
373 strHexBlue := MidStr(MSHTMLColor,6,2);
374 tempColor.RGBColor.R := StrToIntDef('$'+StrHexRed,0);
375 tempColor.RGBColor.G := StrToIntDef('$'+StrHexGreen,0);
376 tempColor.RGBColor.B := StrToIntDef('$'+StrHexBlue,0);
377 Result := tempColor.Color;
378 //NOTE: This function has not yet been tested....
379 end;
380end;
381
382procedure THtmlObj.ToggleBullet;
383begin
384 if DOC=nil then exit;
385 //SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
386 DOC.execCommand('InsertUnorderedList',false,null);
387 Modified:=true;
388end;
389
390procedure THtmlObj.ToggleItalic;
391begin
392 if DOC=nil then exit;
393 DOC.execCommand('Italic',false,null);
394 Modified:=true;
395end;
396
397procedure THtmlObj.ToggleBold;
398begin
399 if DOC=nil then exit;
400 DOC.execCommand('Bold',false,null);
401 Modified:=true;
402end;
403
404procedure THtmlObj.ToggleNumbering;
405begin
406 if DOC=nil then exit;
407 DOC.execCommand('InsertOrderedList',false,null);
408// SpecialCommand(IDM_ORDERLIST,false,true,false,Null);
409 Modified:=true;
410end;
411
412procedure THtmlObj.ToggleUnderline;
413begin
414 if DOC=nil then exit;
415 DOC.execCommand('Underline',false,null);
416 Modified:=true;
417end;
418
419procedure THtmlObj.ToggleSubscript;
420begin
421 if DOC=nil then exit;
422 DOC.execCommand('Subscript',False,0);
423 Modified:=true;
424end;
425
426procedure THtmlObj.ToggleSuperscript;
427begin
428 if DOC=nil then exit;
429 DOC.execCommand('Superscript',False,0);
430 Modified:=true;
431end;
432
433
434procedure THtmlObj.Indent;
435begin
436 if DOC=nil then exit;
437 DOC.ExecCommand('Indent',false,0);
438 Modified:=true;
439end;
440
441procedure THtmlObj.Outdent;
442begin
443 if DOC=nil then exit;
444 DOC.ExecCommand('Outdent',false,0);
445 Modified:=true;
446end;
447
448
449procedure THtmlObj.AlignLeft;
450begin
451 if DOC=nil then exit;
452 DOC.ExecCommand('JustifyLeft',false,0);
453 Modified:=true;
454end;
455
456procedure THtmlObj.AlignRight;
457begin
458 if DOC=nil then exit;
459 DOC.ExecCommand('JustifyRight',false,0);
460 Modified:=true;
461end;
462
463procedure THtmlObj.AlignCenter;
464begin
465 if DOC=nil then exit;
466 DOC.ExecCommand('JustifyCenter',false,0);
467 Modified:=true;
468end;
469
470procedure THtmlObj.TextForeColorDialog;
471begin
472 if ColorDialog = nil then begin
473 ColorDialog := TColorDialog.Create(self);
474 end;
475 if ColorDialog.Execute then begin
476 SetTextForegroundColor(ColorDialog.Color);
477 end;
478 Modified:=true;
479end;
480
481procedure THtmlObj.TextBackColorDialog;
482begin
483 if ColorDialog = nil then begin
484 ColorDialog := TColorDialog.Create(self);
485 end;
486 if ColorDialog.Execute then begin
487 SetTextBackgroundColor(ColorDialog.Color);
488 end;
489 Modified:=true;
490end;
491
492procedure THtmlObj.SetTextForegroundColor(Color:TColor);
493begin
494 if DOC=nil then exit;
495 DOC.ExecCommand('ForeColor',false,Color);
496 Modified:=true;
497end;
498
499function THtmlObj.GetTextForegroundColor:TColor;
500var Background : OleVariant;
501 vt : TVarType;
502begin
503 Result:=clWindow;
504 try
505 if DOC=nil then exit;
506 Background:=DOC.queryCommandValue('ForeColor');
507 vt:=varType(Background);
508 if vt<>varNull then Result:=Background;
509 except
510 on E:Exception do EError('Error retrieving foreground color',E);
511 end;
512end;
513
514procedure THtmlObj.SetTextBackgroundColor(Color:TColor);
515begin
516 if DOC=nil then exit;
517 DOC.ExecCommand('BackColor',false,Color);
518 Modified:=true;
519end;
520
521function THtmlObj.GetTextBackgroundColor:TColor;
522var Background : OleVariant;
523 vt : TVarType;
524begin
525 Result:=clWindow;
526 try
527 if DOC=nil then exit;
528 Background:=DOC.queryCommandValue('BackColor');
529 vt:=varType(Background);
530 if vt<>varNull then Result:=Background;
531 except
532 on E:Exception do EError('Error retrieving background color',E);
533 end;
534end;
535
536procedure THtmlObj.FontDialog;
537begin
538 DoCommand(IDM_FONT);
539 Modified:=true;
540end;
541
542function THtmlObj.GetFontSize : integer;
543var FontSize : OleVariant;
544 vt : TVarType;
545
546begin
547 FontSize:=Doc.queryCommandValue('FontSize');
548 vt:=varType(FontSize);
549 if vt<>varNull then Result := FontSize*FontScale
550 else Result :=12*FontScale; //kt
551end;
552
553procedure THtmlObj.SetFontSize (Size : integer);
554begin
555 if Doc=nil then exit;
556 Doc.ExecCommand('FontSize', false, Size div FontScale);
557end;
558
559function THtmlObj.GetFontName : string;
560var FontName :OleVariant;
561 vt : TVarType;
562begin
563 if DOC=nil then exit;
564 FontName:=DOC.queryCommandValue('FontName');
565 vt:=varType(FontName);
566 if vt<>varNull then Result := FontName
567 else Result :='Times New Roman'; //kt
568end;
569
570procedure THtmlObj.SetFontName (Name : string);
571begin
572 if DOC=nil then exit;
573 DOC.ExecCommand('FontName', false, Name);
574end;
575
576function THtmlObj.SelStart:integer;
577var TextRange:IHtmlTxtRange;
578begin
579 Result:=0;
580 TextRange:=GetTextRange;
581 if TextRange=nil then exit;
582 Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
583end;
584
585function THtmlObj.SelEnd:integer;
586var TextRange:IHtmlTxtRange;
587begin
588 Result:=0;
589 TextRange:=GetTextRange;
590 if TextRange=nil then exit;
591 Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
592end;
593
594function THtmlObj.SelLength:integer;
595begin
596 Result:=SelEnd-SelStart;
597end;
598
599function THtmlObj.GetTextRange:IHtmlTxtRange;
600begin
601 Result:=nil;
602 try
603 if DOC=nil then exit;
604 while DOC.body=nil do begin
605 //WaitLoad(true); //kt
606 WaitForDocComplete;
607 if DOC.body=nil then begin
608 if MessageDlg('Wait for document loading?',mtConfirmation,
609 [mbOK,mbCancel],0) <> mrOK then begin
610 exit;
611 end;
612 end;
613 end;
614 if (DOC.Selection.type_='Text') or (DOC.Selection.type_='None') then begin
615 Result:=DOC.Selection.CreateRange as IHtmlTxtRange;
616 end;
617 except
618 on E:Exception do EError('This type of selection cannot be processed',E);
619 end;
620end;
621
622function THtmlObj.GetSelText:string;
623var TextRange:IHtmlTxtRange;
624begin
625 Result:='';
626 TextRange:=GetTextRange;
627 if TextRange=nil then
628 exit;
629 Result:=TextRange.text;
630end;
631
632procedure THtmlObj.SetSelText (HTMLText : string);
633begin
634 ReplaceSelection(HTMLText);
635end;
636
637procedure THtmlObj.ReplaceSelection(HTML:string);
638var TextRange:IHtmlTxtRange;
639begin
640 try
641 TextRange:=GetTextRange;
642 if TextRange=nil then exit;
643 TextRange.PasteHTML(HTML);
644 Modified:=true;
645 except
646 on E:Exception do begin
647 // implement later... ShortenString(HTML,80);
648 EError('Error pasting HTML'+nl+
649 'Microsoft HTML refuses to paste this string:'+nl+
650 HTML+nl,E);
651 end;
652 end;
653end;
654
655
656function THtmlObj.MoveCaretToEnd : boolean;
657//kt added
658var //TextRange:IHtmlTxtRange;
659 count : integer;
660begin
661 Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_BottomOfWindow,0));
662 count := 0;
663 repeat
664 Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_NextLine,-1));
665 inc (count);
666 until (Result = false) or (count > 500);
667 Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_CurrentLineEnd,0));
668 Result:=(S_OK = FCaret.MoveCaretToPointer(FTMGDisplayPointer,
669 integer(FALSE),
670 CARET_DIRECTION_SAME));
671 {
672 SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
673 SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
674 SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
675 SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
676 }
677end;
678
679function THtmlObj.MoveCaretToPos(ScreenPos: TPoint) : HRESULT;
680//kt added entire function
681var OutTemp : DWORD;
682begin
683 if not assigned (FTMGDisplayPointer) then exit;
684 FTMGDisplayPointer.moveToPoint(ScreenPos, COORD_SYSTEM_GLOBAL, nil, HT_OPT_AllowAfterEOL, OutTemp);
685 Result := FCaret.MoveCaretToPointer(FTMGDisplayPointer,Integer(True),CARET_DIRECTION_INDETERMINATE);
686 FCaret.Show(Integer(True));
687end;
688
689procedure THtmlObj.InsertTextAtCaret(Text : AnsiString);
690//kt added. Note: inserts external format (not HTML markup)
691var P : PWideChar;
692begin
693 P := StringToOleStr(Text);
694 FCaret.InsertText(P,Length(Text))
695end;
696
697
698procedure THtmlObj.Loaded;
699begin
700 inherited Loaded;
701end;
702
703function THtmlObj.GetTextLen : integer;
704begin
705 Result := Length(GetText);
706end;
707
708
709procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
710{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
711begin
712 if TurnOn then begin
713 FApplication.OnMessage := GlobalMsgHandler;
714 end else begin
715 FApplication.OnMessage := FOrigAppOnMessage;
716 end;
717end;
718
719procedure THtmlObj.GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
720{NOTE: This message handler will receive ALL messages directed to CPRS. I
721 have to do this, because something is filtering messages before they
722 get to this THTMLObj object. My goal is to do as little here as possible,
723 and let the OnMessage for THTMLObj (found in EmbeddedED) take care of the rest.
724 NOTE: This should get activated by OnFocus for object, and deactivated
725 by OnBlur, so it actually should only get messages when focused. }
726var
727 i : Integer;
728 NewMsg : TMessage;
729
730 function TransformMessage (WinMsg : TMsg) : TMessage;
731 begin
732 Result.Msg := WinMsg.message;
733 Result.WParam := WinMsg.wParam;
734 Result.LParam := WinMsg.lParam;
735 Result.Result := 0;
736 end;
737
738begin
739 Handled:=false; //default to not handled
740 if (Msg.Message=WM_KEYDOWN) then begin
741 if (Msg.WParam=VK_UP) or (Msg.WParam=VK_DOWN) or (Msg.WParam=VK_TAB) then begin
742 NewMsg := TransformMessage(Msg);
743 SubMessageHandler(NewMsg);
744 Handled := (NewMsg.Result = 1);
745 end;
746 end;
747end;
748
749
750procedure THtmlObj.SubMessageHandler(var Msg: TMessage);
751//Called from parent's EDMessageHandler, or from GlobalMsgHandler
752var i : Integer;
753 WinControl : TWinControl;
754
755begin
756 Msg.Result := 0; //default to not handled
757 if not ((Msg.Msg=WM_KEYDOWN) or
758 (Msg.Msg=WM_KEYUP) or
759 (Msg.Msg=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
760 case Msg.Msg of
761 WM_RBUTTONUP : begin
762 if CtrlToBeProcessed then begin
763 CtrlToBeProcessed := false;
764 exit; //Ctrl-right click is ignored
765 end;
766 if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
767 Msg.Result := 1; //Handled
768 exit;
769 end;
770 WM_KEYDOWN : begin
771 GetSystemTimeAsFileTime(KeyPressTime);
772 KeyStruck := true;
773 //beep(200,50);
774 case Msg.WParam of
775 VK_ESCAPE : begin
776 if Assigned(PrevControl) then begin
777 AllowNextBlur := true;
778 PrevControl.SetFocus;
779 end;
780 end;
781 VK_CONTROL : begin
782 CtrlToBeProcessed:=true;
783 Msg.Result := 1; //Handled
784 exit;
785 end;
786 VK_SHIFT : begin
787 ShiftToBeProcessed:=true;
788 Msg.Result := 1; //Handled
789 exit;
790 end;
791 VK_TAB : begin
792 if (ShiftToBeProcessed and CtrlToBeProcessed) then begin
793 //This isn't working for some reason...
794 for i := 0 to 5 do begin
795 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_LEFT, 0);
796 end;
797 ShiftToBeProcessed := false;
798 CtrlToBeProcessed := false;
799 end else if ShiftToBeProcessed then begin
800 if Assigned(PrevControl) then begin
801 AllowNextBlur := true;
802 PrevControl.SetFocus;
803 end;
804 ShiftToBeProcessed := false;
805 end else if CtrlToBeProcessed then begin
806 if Assigned(NextControl) then begin
807 AllowNextBlur := true;
808 NextControl.SetFocus;
809 end;
810 CtrltoBeProcessed := false;
811 end else begin
812 for i := 0 to 5 do begin
813 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_SPACE, 0);
814 end;
815 end;
816 Msg.Result := 1; //Handled
817 end;
818 {
819 VK_RETURN : if CtrlReturnToBeProcessed then begin
820 Msg.Result := 1; //Handled
821 CtrlReturnToBeProcessed := false;
822 end else if CtrlToBeProcessed then begin
823 Msg.Result := 1; //Handled
824 CtrlToBeProcessed := False;
825 CtrlReturnToBeProcessed := true;
826 //PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
827 end else if ShiftToBeProcessed=false then begin
828 //kt if not FEditable then exit;
829 keybd_event(VK_SHIFT,0,0,0);
830 keybd_event(VK_RETURN,0,0,0);
831 keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
832 Msg.Result := 1; //Handled
833 end;
834 }
835 Ord('B') : if CtrlToBeProcessed then begin
836 //kt if not FEditable then exit;
837 ToggleBold;
838 Msg.Result := 1; //Handled
839 exit;
840 end;
841 Ord('U') : if CtrlToBeProcessed then begin
842 //kt if not FEditable then exit;
843 ToggleUnderline;
844 Msg.Result := 1; //Handled
845 exit;
846 end;
847 Ord('I') : if CtrlToBeProcessed then begin
848 //kt if not FEditable then exit;
849 ToggleItalic;
850 Msg.Result := 1; //Handled
851 end;
852 end; {case}
853 end;
854 WM_KEYUP : begin
855 case Msg.WParam of
856 VK_CONTROL : begin
857 CtrlToBeProcessed:=false;
858 Msg.Result := 1; //Handled
859 if CtrlReturnToBeProcessed then begin
860 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_RETURN, 0);
861 end;
862 exit;
863 end;
864 VK_SHIFT : begin
865 ShiftToBeProcessed:=false;
866 Msg.Result := 1; //Handled
867 exit;
868 end;
869
870 end; {case}
871 exit;
872 end;
873 end; {case}
874end;
875
876procedure THtmlObj.HandleBlur(Sender: TObject);
877//kt added function
878 function RecentKeyPressed : boolean;
879 var NowTime : FILETIME; //kt
880 KeyTime,NowTime2 : LARGE_INTEGER;
881 Delta : int64;
882 begin
883 GetSystemTimeAsFileTime(NowTime);
884 NowTime2.LowPart := NowTime.dwLowDateTime;
885 NowTime2.HighPart := NowTime.dwHighDateTime;
886 KeyTime.LowPart := KeyPressTime.dwLowDateTime;
887 KeyTime.HighPart := KeyPressTime.dwHighDateTime;
888 Delta := floor( (NowTime2.QuadPart - KeyTime.QuadPart) / 100000);
889 Result := (Delta < 100);
890 end;
891
892begin
893 //kt Handle loss of focus when attempting to cursor above top line, or below bottom line.
894 if (not AllowNextBlur) and RecentKeyPressed then begin //kt entire block
895 SetFocusToDoc;
896 //beep(880,100);
897 KeyPressTime.dwLowDateTime := 0;
898 KeyPressTime.dwHighDateTime := 0;
899 exit;
900 end;
901 AllowNextBlur := false;
902 SetMsgActive(false);
903end;
904
905function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
906begin
907 SetMsgActive(fGotFocus);
908end;
909
910function THtmlObj.GetActive : boolean;
911begin
912 Result := TWinControl(Owner).Visible;
913end;
914
915
916initialization
917
918finalization
919
920end.
921
Note: See TracBrowser for help on using the repository browser.