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

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

Fixed New Note-Template Tab Key issue
File size: 29.2 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 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 if not assigned (FTMGDisplayPointer) then begin
662 Result := false;
663 exit;
664 end;
665 Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_BottomOfWindow,0));
666 count := 0;
667 repeat
668 Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_NextLine,-1));
669 inc (count);
670 until (Result = false) or (count > 500);
671 Result:=(S_OK = FTMGDisplayPointer.MoveUnit(DISPLAY_MOVEUNIT_CurrentLineEnd,0));
672 Result:=(S_OK = FCaret.MoveCaretToPointer(FTMGDisplayPointer,
673 integer(FALSE),
674 CARET_DIRECTION_SAME));
675 {
676 SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
677 SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
678 SendMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_END, 0);
679 SendMessage(FmsHTMLwinHandle, WM_KEYUP, VK_END, 0);
680 }
681end;
682
683function THtmlObj.MoveCaretToPos(ScreenPos: TPoint) : HRESULT;
684//kt added entire function
685var OutTemp : DWORD;
686begin
687 if not assigned (FTMGDisplayPointer) then exit;
688 FTMGDisplayPointer.moveToPoint(ScreenPos, COORD_SYSTEM_GLOBAL, nil, HT_OPT_AllowAfterEOL, OutTemp);
689 Result := FCaret.MoveCaretToPointer(FTMGDisplayPointer,Integer(True),CARET_DIRECTION_INDETERMINATE);
690 FCaret.Show(Integer(True));
691end;
692
693procedure THtmlObj.InsertTextAtCaret(Text : AnsiString);
694//kt added. Note: inserts external format (not HTML markup)
695var P : PWideChar;
696begin
697 P := StringToOleStr(Text);
698 FCaret.InsertText(P,Length(Text))
699end;
700
701
702procedure THtmlObj.Loaded;
703begin
704 inherited Loaded;
705end;
706
707function THtmlObj.GetTextLen : integer;
708begin
709 Result := Length(GetText);
710end;
711
712
713procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
714{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
715begin
716 if TurnOn then begin
717 FApplication.OnMessage := GlobalMsgHandler;
718 end else begin
719 FApplication.OnMessage := FOrigAppOnMessage;
720 end;
721end;
722
723procedure THtmlObj.GlobalMsgHandler(var Msg: TMsg; var Handled: Boolean);
724{NOTE: This message handler will receive ALL messages directed to CPRS. I
725 have to do this, because something is filtering messages before they
726 get to this THTMLObj object. My goal is to do as little here as possible,
727 and let the OnMessage for THTMLObj (found in EmbeddedED) take care of the rest.
728 NOTE: This should get activated by OnFocus for object, and deactivated
729 by OnBlur, so it actually should only get messages when focused. }
730var
731 i : Integer;
732 NewMsg : TMessage;
733
734 function TransformMessage (WinMsg : TMsg) : TMessage;
735 begin
736 Result.Msg := WinMsg.message;
737 Result.WParam := WinMsg.wParam;
738 Result.LParam := WinMsg.lParam;
739 Result.Result := 0;
740 end;
741
742begin
743 Handled:=false; //default to not handled
744 if (Msg.Message=WM_KEYDOWN) then begin
745 if (Msg.WParam=VK_UP) or (Msg.WParam=VK_DOWN) or (Msg.WParam=VK_TAB) then begin
746 NewMsg := TransformMessage(Msg);
747 SubMessageHandler(NewMsg);
748 Handled := (NewMsg.Result = 1);
749 end;
750 end;
751end;
752
753
754procedure THtmlObj.SubMessageHandler(var Msg: TMessage);
755//Called from parent's EDMessageHandler, or from GlobalMsgHandler
756var i : Integer;
757 WinControl : TWinControl;
758
759begin
760 Msg.Result := 0; //default to not handled
761 if not ((Msg.Msg=WM_KEYDOWN) or
762 (Msg.Msg=WM_KEYUP) or
763 (Msg.Msg=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
764 case Msg.Msg of
765 WM_RBUTTONUP : begin
766 if CtrlToBeProcessed then begin
767 CtrlToBeProcessed := false;
768 exit; //Ctrl-right click is ignored
769 end;
770 if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
771 Msg.Result := 1; //Handled
772 exit;
773 end;
774 WM_KEYDOWN : begin
775 GetSystemTimeAsFileTime(KeyPressTime);
776 KeyStruck := true;
777 //beep(200,50);
778 case Msg.WParam of
779 VK_ESCAPE : begin
780 if Assigned(PrevControl) then begin
781 AllowNextBlur := true;
782 PrevControl.SetFocus;
783 end;
784 end;
785 VK_CONTROL : begin
786 CtrlToBeProcessed:=true;
787 Msg.Result := 1; //Handled
788 exit;
789 end;
790 VK_SHIFT : begin
791 ShiftToBeProcessed:=true;
792 Msg.Result := 1; //Handled
793 exit;
794 end;
795 VK_TAB : begin
796 if (ShiftToBeProcessed and CtrlToBeProcessed) then begin
797 //This isn't working for some reason...
798 for i := 0 to 5 do begin
799 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_LEFT, 0);
800 end;
801 ShiftToBeProcessed := false;
802 CtrlToBeProcessed := false;
803 end else if ShiftToBeProcessed then begin
804 if Assigned(PrevControl) then begin
805 AllowNextBlur := true;
806 PrevControl.SetFocus;
807 end;
808 ShiftToBeProcessed := false;
809 end else if CtrlToBeProcessed then begin
810 if Assigned(NextControl) then begin
811 AllowNextBlur := true;
812 NextControl.SetFocus;
813 end;
814 CtrltoBeProcessed := false;
815 end else begin
816 for i := 0 to 5 do begin
817 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_SPACE, 0);
818 end;
819 end;
820 Msg.Result := 1; //Handled
821 end;
822 {
823 VK_RETURN : if CtrlReturnToBeProcessed then begin
824 Msg.Result := 1; //Handled
825 CtrlReturnToBeProcessed := false;
826 end else if CtrlToBeProcessed then begin
827 Msg.Result := 1; //Handled
828 CtrlToBeProcessed := False;
829 CtrlReturnToBeProcessed := true;
830 //PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
831 end else if ShiftToBeProcessed=false then begin
832 //kt if not FEditable then exit;
833 keybd_event(VK_SHIFT,0,0,0);
834 keybd_event(VK_RETURN,0,0,0);
835 keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
836 Msg.Result := 1; //Handled
837 end;
838 }
839 Ord('B') : if CtrlToBeProcessed then begin
840 //kt if not FEditable then exit;
841 ToggleBold;
842 Msg.Result := 1; //Handled
843 exit;
844 end;
845 Ord('U') : if CtrlToBeProcessed then begin
846 //kt if not FEditable then exit;
847 ToggleUnderline;
848 Msg.Result := 1; //Handled
849 exit;
850 end;
851 Ord('I') : if CtrlToBeProcessed then begin
852 //kt if not FEditable then exit;
853 ToggleItalic;
854 Msg.Result := 1; //Handled
855 end;
856 end; {case}
857 end;
858 WM_KEYUP : begin
859 case Msg.WParam of
860 VK_CONTROL : begin
861 CtrlToBeProcessed:=false;
862 Msg.Result := 1; //Handled
863 if CtrlReturnToBeProcessed then begin
864 PostMessage(FmsHTMLwinHandle, WM_KEYDOWN, VK_RETURN, 0);
865 end;
866 exit;
867 end;
868 VK_SHIFT : begin
869 ShiftToBeProcessed:=false;
870 Msg.Result := 1; //Handled
871 exit;
872 end;
873
874 end; {case}
875 exit;
876 end;
877 end; {case}
878end;
879
880procedure THtmlObj.HandleBlur(Sender: TObject);
881//kt added function
882 function RecentKeyPressed : boolean;
883 var NowTime : FILETIME; //kt
884 KeyTime,NowTime2 : LARGE_INTEGER;
885 Delta : int64;
886 begin
887 GetSystemTimeAsFileTime(NowTime);
888 NowTime2.LowPart := NowTime.dwLowDateTime;
889 NowTime2.HighPart := NowTime.dwHighDateTime;
890 KeyTime.LowPart := KeyPressTime.dwLowDateTime;
891 KeyTime.HighPart := KeyPressTime.dwHighDateTime;
892 Delta := floor( (NowTime2.QuadPart - KeyTime.QuadPart) / 100000);
893 Result := (Delta < 100) and (Delta > 0);
894 end;
895
896begin
897 //kt Handle loss of focus when attempting to cursor above top line, or below bottom line.
898 if (not AllowNextBlur) and RecentKeyPressed then begin //kt entire block
899 SetFocusToDoc;
900 //beep(880,100);
901 KeyPressTime.dwLowDateTime := 0;
902 KeyPressTime.dwHighDateTime := 0;
903 exit;
904 end;
905 AllowNextBlur := false;
906 SetMsgActive(false);
907end;
908
909function THtmlObj.SubFocusHandler(fGotFocus: BOOL): HResult;
910begin
911 SetMsgActive(fGotFocus);
912end;
913
914function THtmlObj.GetActive : boolean;
915begin
916 Result := TWinControl(Owner).Visible;
917end;
918
919
920initialization
921
922finalization
923
924end.
925
Note: See TracBrowser for help on using the repository browser.