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

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

TMG Ver 1.1 Added HTML Support, better demographics editing

File size: 33.3 KB
Line 
1unit TMGHTML;
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
23interface
24
25uses SysUtils, WinTypes, Dialogs, StdCtrls, Menus,
26 EmbeddedED,
27 ActiveX, MSHTMLEvents, SHDocVw, {MSHTML,} MSHTML_EWB,
28 AppEvnts,
29 IeConst,Messages,Classes,Forms,Graphics;
30
31const
32 CGID_MSHTML:TGUID='{DE4BA900-59CA-11CF-9592-444553540000}';
33 IID_IOleCommandTarget:TGUID='{B722BCCB-4E68-101B-A2BC-00AA00404770}';
34 CGID_WebBrowser:TGUID='{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
35 FontScale=3;
36
37type
38 TSetFontMode = (sfAll,sfSize,sfColor,sfName,sfStyle,sfCharset);
39
40 TRGBColor = record
41 R : byte;
42 G : byte;
43 B : byte;
44 end; {record}
45
46 TMGColor = record
47 case boolean of
48 True: (Color : TColor);
49 False: (RGBColor : TRGBColor);
50 end; {record}
51
52type
53 // THtmlObj=class(TWebBrowser)
54 THtmlObj=class(TEmbeddedED)
55 private
56 FEditable: boolean;
57 Modified: boolean;
58 DocEvents: TMSHTMLHTMLDocumentEvents; //elh
59 WinEvents: TMSHTMLHTMLWindowEvents2;
60 CtrlReturnToBeProcessed: boolean;
61 CtrlToBeProcessed : boolean;
62 ShiftToBeProcessed : boolean;
63 ColorDialog: TColorDialog;
64 FOrigAppOnMessage : TMessageEvent;
65 FCustKeyboardHandlerOn: boolean;
66 FActive : boolean;
67 FApplication : TApplication;
68 procedure WaitLoad(peek:boolean);
69 function GetEditableState : boolean;
70 procedure SetEditableState (EditOn : boolean);
71 procedure SetBackgroundColor(Color:TColor);
72 function GetBackgroundColor : TColor;
73 procedure SetTextBackgroundColor(Color:TColor);
74 function GetTextBackgroundColor : TColor;
75 procedure SetTextForegroundColor(Color:TColor);
76 function GetTextForegroundColor : TColor;
77 function GetFontSize : integer;
78 procedure SetFontSize (Size : integer);
79 function GetFontName : string;
80 procedure SetFontName (Name : string);
81 procedure SetActive (Active : boolean);
82 function GetHTMLText:string;
83 procedure SetHTMLText(HTML:String);
84 function GetText:string;
85 procedure SetText(HTML:string);
86 function GetSelText:string;
87 procedure SetSelText (HTMLText : string);
88 procedure DefineDocEvents; //elh
89 procedure DefineWinEvents;
90 procedure OnDocFocusOut(Sender:TObject); //elh
91
92 procedure SetDefaultFont;
93 function ColorToMSHTMLStr(color : TColor) : string;
94 function MSHTMLStrToColor(MSHTMLColor : string) : TColor;
95
96 //Events ------------------
97 procedure NavigateComplete2(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
98 procedure LocalMessageHandler(var Msg: TMsg; var Handled: Boolean);
99 procedure CompleteLoading;
100 procedure ProcessLoadMessages;
101 function SpecialCommand(Cmd : Cardinal; PromptUser : boolean;
102 editModeOnly : boolean; bTriEditCommandGroup : boolean;
103 InputArgs : OleVariant) : HRESULT;
104 function HrExecCommand(ucmdID: cardinal;
105 const pVarIn: OleVariant; var pVarOut: OleVariant; bPromptUser,
106 bTriEditCmdGroup: boolean): HResult;
107 procedure ReassignKeyboardHandler(TurnOn : boolean);
108 {end private}
109 public
110 TheDoc: IHTMLDocument2; //MSHTML HTML Document 2 interface
111// HTMLEvents: HTMLWindowsEvents2;
112 TheWind: IHTMLWindow2;
113 DocCmd,WebCmd: IOleCommandTarget; //MSHTML IOLECommandTarget interface
114 PopupMenu: TPopupMenu;
115 DefaultFontSize : Integer;
116 DefaultFontName : string;
117 constructor Create(Owner:TComponent; Application : TApplication);
118 destructor Destroy; override;
119 //Properties ---
120 property Editable : boolean read GetEditableState write SetEditableState;
121 property BackgroundColor : TColor read GetBackgroundColor write SetBackgroundColor;
122 property TextBackgroundColor : TColor read GetTextBackgroundColor write SetTextBackgroundColor;
123 property TextForegroundColor : TColor read GetTextForegroundColor write SetTextForegroundColor;
124 property FontSize : integer read GetFontSize write SetFontSize;
125 property FontName : string read GetFontName write SetFontName;
126 property HTMLText:string read GetHTMLText write SetHTMLText;
127 property Text:string read GetText write SetText;
128 property Active : boolean read FActive write SetActive;
129 property SelText : string read GetSelText write SetSelText;
130 //Methods -------
131 function GetTextLen : integer;
132 procedure Clear;
133 procedure LoadFile(FileName:string);
134
135 procedure ToggleBullet;
136 procedure ToggleItalic;
137 procedure ToggleBold;
138 procedure ToggleNumbering;
139 procedure ToggleUnderline;
140 procedure ToggleSubscript;
141 procedure ToggleSuperscript;
142 procedure Indent;
143 procedure Outdent;
144 procedure AlignLeft;
145 procedure AlignRight;
146 procedure AlignCenter;
147 procedure FontDialog;
148 procedure TextForeColorDialog;
149 procedure TextBackColorDialog;
150
151 procedure SetSelection(Start,Length:integer);
152 function GetTextRange:IHtmlTxtRange;
153 function SelStart:integer;
154 function SelEnd:integer;
155 function SelLength:integer;
156
157 procedure ClearSelection;
158 procedure ReplaceSelection(HTML:string);
159 {end public}
160 end;
161
162type THtmlEditor=class(THtmlObj);
163
164implementation
165
166
167uses
168 WinProcs,Controls,Variants,Clipbrd, StrUtils;
169
170const
171 MaxTextLength = 100;
172 nl = #13#10;
173
174procedure EError(EText : string; E : Exception);
175begin
176 MessageDlg(EText,mtError,[mbOK],0);
177end;
178
179constructor THtmlObj.Create(Owner:TComponent; Application : TApplication);
180begin
181 inherited Create(Owner);
182 TheDoc:=nil;
183 DocCmd:=nil;
184 WebCmd:=nil;
185 ColorDialog := nil;
186 FApplication := Application;
187 FOrigAppOnMessage := Application.OnMessage;
188 FEditable := false;
189 DefaultFontSize := 10;
190 OnBlur := OnDocFocusOut;
191 DefaultFontName := 'Times New Roman';
192 FCustKeyboardHandlerOn := false;
193 OnNavigateComplete2 := NavigateComplete2;
194end;
195
196destructor THtmlObj.Destroy;
197begin
198 SetActive(false); // ReassignKeyboardHandler(false);
199 ColorDialog.Free;
200 inherited Destroy;
201end;
202
203
204procedure THtmlObj.LoadFile(FileName:string);
205var OldWidth,OldHeight:integer;
206begin
207 try
208 self.Cursor := crHourGlass;
209 OldHeight:=Height;
210 OldWidth:=Width;
211 Navigate(FileName);
212 Width:=OldWidth; {due to a bug that sizes down HTML components on start}{Oct 15, 2001}
213 Height:=OldHeight;
214 TheDoc:=nil;
215 if DocCmd<>nil then begin
216 DocCmd._Release;
217 DocCmd:=nil;
218 end;
219 WaitLoad(true); //kt
220 self.Cursor := crDefault; //kt
221 except
222 on E:Exception do begin
223 EError('Cannot load '+Filename,E);
224 end;
225 end;
226end;
227
228
229procedure THtmlObj.WaitLoad(peek:boolean);
230begin
231 try
232 TheDoc:=Document as IHTMLDocument2;
233 while TheDoc=nil do begin
234 if peek then ProcessLoadMessages
235 else exit;
236 TheDoc:=Document as IHTMLDocument2;
237 end;
238
239 repeat
240 ControlInterface.QueryInterface(IID_IOleCommandTarget,WebCmd);
241 until WebCmd<>nil;
242
243 repeat
244 TheDoc.QueryInterface(IOleCommandTarget,DocCmd);
245 until DocCmd<>nil;
246
247 repeat
248 TheWind:=TheDoc.parentWindow;
249 until TheWind<>nil;
250
251 while (TheDoc=nil)or((theDoc.ReadyState<>'complete')and(theDoc.ReadyState<>'interactive')) do begin
252 {remove messages that should not be processed while the element is loading}
253 {TheDoc can become nil when switching applications!}
254 if TheDoc=nil then
255 MessageBeep(0); {this beep is sounded while page is loading while control is no longer in forefront}
256 if peek then
257 ProcessLoadMessages
258 else
259 exit;
260 end;
261
262 except
263 on E:Exception do EError('Error loading the document',E);
264 end;
265end;
266
267
268procedure THtmlObj.ProcessLoadMessages;
269var msg:TMsg;
270 MessageQueue:array of TMsg;
271 m:integer;
272begin
273 while PeekMessage(msg,0,wm_KeyFirst,wm_KeyLast,pm_Remove) do; {remove keyboard input first}
274 while PeekMessage(msg,0,wm_MouseFirst,wm_MouseLast,pm_Remove) do; {remove mouse input}
275 while PeekMessage(msg,0,wm_Close,wm_Close,pm_Remove) do; {disallow closing the application}
276 while PeekMessage(msg,0,wm_ActivateApp,wm_ActivateApp,pm_Remove) do; {disallow activating the application}
277 //ktwhile PeekMessage(msg,0,wm_User,cm_LastUserMessage,pm_Remove) do begin
278 while PeekMessage(msg,0,wm_User,wm_User+$200,pm_Remove) do begin
279 SetLength(MessageQueue,length(MessageQueue)+1);
280 MessageQueue[length(MessageQueue)-1]:=msg;
281 end;
282 forms.Application.ProcessMessages; {process messages needed to complete navigation}
283 for m:=1 to length(MessageQueue) do begin
284 msg:=MessageQueue[m-1];
285 PostMessage(msg.hwnd,msg.message,msg.WParam,msg.lParam);
286 end;
287end;
288
289function THtmlObj.SpecialCommand(Cmd:Cardinal;PromptUser:boolean;
290 editModeOnly:boolean;bTriEditCommandGroup:boolean;
291 InputArgs:OleVariant):HRESULT;
292begin
293 Result:=HrExecCommand(Cmd,null,InputArgs,promptUser,bTriEditCommandGroup);
294end;
295
296
297function THtmlObj.HrExecCommand(ucmdID: cardinal; const pVarIn: OleVariant;
298 var pVarOut: OleVariant; bPromptUser,
299 bTriEditCmdGroup: boolean): HResult;
300var dwCmdOpt:DWORD;
301begin
302 result := S_OK;
303 if DocCmd = nil then Exit;
304 if (bPromptUser) then dwCmdOpt := MSOCMDEXECOPT_PROMPTUSER
305 else dwCmdOpt := MSOCMDEXECOPT_DONTPROMPTUSER;
306 if (bTriEditCmdGroup) then
307 result := DocCmd.Exec(@GUID_TriEditCommandGroup,ucmdID,dwCmdOpt,pVarIn,pVarOut)
308 else
309 result := DocCmd.Exec(@CMDSETID_Forms3,ucmdID,dwCmdOpt,pVarIn,pVarOut);
310end;
311
312procedure THtmlObj.SetDefaultFont;
313begin
314 if DefaultFontName <> '' then SetFontName(DefaultFontName);
315 if DefaultFontSize <> 0 then SetFontSize(DefaultFontSize);
316end;
317
318
319function THtmlObj.GetEditableState : boolean;
320var mode : string;
321begin
322 mode := TheDoc.designMode;
323 result := (mode = 'On');
324end;
325
326procedure THtmlObj.SetEditableState(EditOn : boolean);
327var LastMode : string;
328 count : integer;
329begin
330 LastMode := 'Inherit';
331 try
332 count := 0;
333 repeat
334 inc (count);
335 if TheDoc = nil then begin
336 FApplication.ProcessMessages;
337 Sleep (100);
338 continue;
339 end else if TheDoc.body = nil then begin
340 FApplication.ProcessMessages;
341 Sleep (100);
342 continue;
343 end;
344 if EditOn then begin
345 TheDoc.body.setAttribute('contentEditable','true',0);
346 TheDoc.designMode := 'On'; //kt
347 FEditable:=true;
348 //SetFocus;
349 end else begin
350 TheDoc.body.setAttribute('contentEditable','false',0);
351 TheDoc.designMode := 'Off'; //kt
352 FEditable:=false;
353 end;
354 LastMode := TheDoc.designMode;
355 until (LastMode <> 'Inherit') or (count > 20);
356 except
357 on E:Exception do EError('Error switching into HTML editing state',E);
358 end;
359end;
360
361procedure THtmlObj.ToggleBullet;
362begin
363 if TheDoc=nil then exit;
364 //SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
365 TheDoc.execCommand('InsertUnorderedList',false,null);
366 Modified:=true;
367end;
368
369procedure THtmlObj.ToggleItalic;
370begin
371 if TheDoc=nil then exit;
372 //SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
373 TheDoc.execCommand('Italic',false,null);
374 Modified:=true;
375end;
376
377procedure THtmlObj.ToggleBold;
378begin
379 if TheDoc=nil then exit;
380 TheDoc.execCommand('Bold',false,null);
381 Modified:=true;
382end;
383
384procedure THtmlObj.ToggleNumbering;
385begin
386 if TheDoc=nil then exit;
387 TheDoc.execCommand('InsertOrderedList',false,null);
388// SpecialCommand(IDM_ORDERLIST,false,true,false,Null);
389 Modified:=true;
390end;
391
392procedure THtmlObj.ToggleUnderline;
393begin
394 if TheDoc=nil then exit;
395 TheDoc.execCommand('Underline',false,null);
396 Modified:=true;
397end;
398
399procedure THtmlObj.ToggleSubscript;
400begin
401 if TheDoc=nil then exit;
402 TheDoc.execCommand('Subscript',False,0);
403 Modified:=true;
404end;
405
406procedure THtmlObj.ToggleSuperscript;
407begin
408 if TheDoc=nil then exit;
409 TheDoc.execCommand('Superscript',False,0);
410 Modified:=true;
411end;
412
413
414procedure THtmlObj.Indent;
415begin
416 if TheDoc=nil then exit;
417 TheDoc.ExecCommand('Indent',false,0);
418 Modified:=true;
419end;
420
421procedure THtmlObj.Outdent;
422begin
423 if TheDoc=nil then exit;
424 TheDoc.ExecCommand('Outdent',false,0);
425 Modified:=true;
426end;
427
428
429procedure THtmlObj.AlignLeft;
430begin
431 if TheDoc=nil then exit;
432 TheDoc.ExecCommand('JustifyLeft',false,0);
433 Modified:=true;
434end;
435
436procedure THtmlObj.AlignRight;
437begin
438 if TheDoc=nil then exit;
439 TheDoc.ExecCommand('JustifyRight',false,0);
440 Modified:=true;
441end;
442
443procedure THtmlObj.AlignCenter;
444begin
445 if TheDoc=nil then exit;
446 TheDoc.ExecCommand('JustifyCenter',false,0);
447 Modified:=true;
448end;
449
450
451procedure THtmlObj.SetBackgroundColor(Color:TColor);
452begin
453 if TheDoc=nil then exit;
454 WaitLoad(true); //kt
455 if TheDoc.body=nil then exit;
456 TheDoc.body.style.backgroundColor := ColorToMSHTMLStr(Color);
457end;
458
459function THtmlObj.GetBackgroundColor : TColor;
460begin
461 Result := clBlack; //default;
462 if TheDoc=nil then exit;
463 if TheDoc.body=nil then exit;
464 Result := MSHTMLStrToColor(TheDoc.body.style.backgroundColor);
465end;
466
467procedure THtmlObj.TextForeColorDialog;
468begin
469 if ColorDialog = nil then begin
470 ColorDialog := TColorDialog.Create(self);
471 end;
472 if ColorDialog.Execute then begin
473 SetTextForegroundColor(ColorDialog.Color);
474 end;
475 Modified:=true;
476end;
477
478procedure THtmlObj.TextBackColorDialog;
479begin
480 if ColorDialog = nil then begin
481 ColorDialog := TColorDialog.Create(self);
482 end;
483 if ColorDialog.Execute then begin
484 SetTextBackgroundColor(ColorDialog.Color);
485 end;
486 Modified:=true;
487end;
488
489procedure THtmlObj.SetTextBackgroundColor(Color:TColor);
490begin
491 if TheDoc=nil then exit;
492 TheDoc.ExecCommand('BackColor',false,Color);
493 Modified:=true;
494end;
495
496function THtmlObj.GetTextBackgroundColor:TColor;
497var Background : OleVariant;
498 vt : TVarType;
499begin
500 Result:=clWindow;
501 try
502 if TheDoc=nil then exit;
503 Background:=TheDoc.queryCommandValue('BackColor');
504 vt:=varType(Background);
505 if vt<>varNull then Result:=Background;
506 except
507 on E:Exception do EError('Error retrieving background color',E);
508 end;
509end;
510
511procedure THtmlObj.SetTextForegroundColor(Color:TColor);
512begin
513 if TheDoc=nil then exit;
514 TheDoc.ExecCommand('ForeColor',false,Color);
515 Modified:=true;
516end;
517
518function THtmlObj.GetTextForegroundColor:TColor;
519var Background : OleVariant;
520 vt : TVarType;
521begin
522 Result:=clWindow;
523 try
524 if TheDoc=nil then exit;
525 Background:=TheDoc.queryCommandValue('ForeColor');
526 vt:=varType(Background);
527 if vt<>varNull then Result:=Background;
528 except
529 on E:Exception do EError('Error retrieving foreground color',E);
530 end;
531end;
532
533procedure THtmlObj.FontDialog;
534begin
535 SpecialCommand(IDM_FONT,True,True,False,Null);
536 Modified:=true;
537end;
538
539function THtmlObj.GetFontSize : integer;
540var FontSize : OleVariant;
541 vt : TVarType;
542begin
543 FontSize:=TheDoc.queryCommandValue('FontSize');
544 vt:=varType(FontSize);
545 if vt<>varNull then Result := FontSize*FontScale
546 else Result :=12*FontScale; //kt
547end;
548
549procedure THtmlObj.SetFontSize (Size : integer);
550begin
551 if TheDoc=nil then exit;
552 TheDoc.ExecCommand('FontSize', false, Size div FontScale);
553end;
554
555function THtmlObj.GetFontName : string;
556var FontName :OleVariant;
557 vt : TVarType;
558begin
559 if TheDoc=nil then exit;
560 FontName:=TheDoc.queryCommandValue('FontName');
561 vt:=varType(FontName);
562 if vt<>varNull then Result := FontName
563 else Result :='Times New Roman'; //kt
564end;
565
566procedure THtmlObj.SetFontName (Name : string);
567begin
568 if TheDoc=nil then exit;
569 TheDoc.ExecCommand('FontName', false, Name);
570end;
571
572procedure THtmlObj.SetActive (Active : boolean);
573//NOTE: This object grabs the OnMessage for the entire application, so that
574// it can intercept the right-click. As a result, the object needs a
575// way that it can turn off this feature when it is covered up by other
576// windows application subwindows etc. This function provides this.
577begin
578 FActive := Active;
579 ReassignKeyboardHandler(FActive);
580end;
581
582
583procedure THtmlObj.NavigateComplete2(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
584begin
585 CompleteLoading;
586end;
587
588procedure THtmlObj.CompleteLoading;
589begin
590 Waitload(false); {used only to set up interface variables}
591 SetActive(true); // ReassignKeyboardHandler(true);
592 //DefineDocEvents; //elh
593end;
594
595
596procedure THtmlObj.DefineDocEvents;
597//NOTE: When this function is called, keyboard strokes fire this event, but then
598// the characters never show up in the editor window as having been typed.
599begin
600 // if DocEvents<>nil then Events.Free;
601 // DocEvents := TMSHTMLHTMLDocumentEvents.Create(Self);
602 // DocEvents.Connect(IUnknown(Document));
603 // DocEvents.OnFocusOut:=OnDocFocusOut;
604end;
605
606procedure THtmlObj.DefineWinEvents;
607//NOTE: When this function is called, keyboard strokes fire this event, but then
608// the characters never show up in the editor window as having been typed.
609begin
610 //if DocEvents<>nil then Events.Free;
611 //WinEvents := TMSHTMLHTMLWindowEvents2.Create(Self);
612 //DocEvents.Connect(IUnknown(Document));
613 //DocEvents.OnFocusOut:=OnDocFocusOut;
614end;
615
616procedure THtmlObj.OnDocFocusOut(Sender:TObject);
617begin
618 messagedlg('This is the new one', mtWarning,mbOKCancel,0);
619end;
620
621
622
623procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
624{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
625begin
626 if TurnOn then begin
627 FApplication.OnMessage := LocalMessageHandler;
628 FCustKeyboardHandlerOn := true;
629 end else begin
630 FApplication.OnMessage := FOrigAppOnMessage;
631 FCustKeyboardHandlerOn := false;
632 end;
633end;
634
635
636procedure THtmlObj.LocalMessageHandler(var Msg: TMsg; var Handled: Boolean);
637var
638 Cursor : TPoint;
639 i : Integer;
640
641begin
642 Handled:=false; //default to not handled
643 exit;
644 if not FCustKeyboardHandlerOn then exit;
645 if not ((Msg.Message=WM_KEYDOWN) or
646 (Msg.Message=WM_KEYUP) or
647 (Msg.Message=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
648 case Msg.Message of
649 WM_RBUTTONUP : begin
650 Cursor := ScreenToClient(Msg.pt);
651 //Ignore message if mouse not over this HTML control
652 if (Cursor.X<0) or (Cursor.X>Width) or
653 (Cursor.Y<0) or (Cursor.Y>Height) then exit;
654 if CtrlToBeProcessed then begin
655 CtrlToBeProcessed := false;
656 exit; //Ctrl-right click is ignored
657 end;
658 if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
659 Handled:=true;
660 exit;
661 end;
662 WM_KEYDOWN : begin
663 case Msg.WParam of
664 VK_CONTROL : begin
665 CtrlToBeProcessed:=true;
666 Handled:=true;
667 exit;
668 end;
669 VK_SHIFT : begin
670 ShiftToBeProcessed:=true;
671 Handled:=true;
672 exit;
673 end;
674 VK_TAB : begin
675 //kt if not FEditable then exit;
676 if ShiftToBeProcessed then begin
677 for i := 0 to 5 do begin
678 PostMessage(Msg.hwnd, WM_KEYDOWN, VK_LEFT, 0);
679 end;
680 end else begin
681 for i := 0 to 5 do begin
682 PostMessage(Msg.hwnd, WM_KEYDOWN, VK_SPACE, 0);
683 end;
684 end;
685 Handled:=true;
686 end;
687 VK_RETURN : if CtrlReturnToBeProcessed then begin
688 Handled:=false;
689 CtrlReturnToBeProcessed := false;
690 end else if CtrlToBeProcessed then begin
691 Handled:=true;
692 CtrlToBeProcessed := False;
693 CtrlReturnToBeProcessed := true;
694 //PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
695 end else if ShiftToBeProcessed=false then begin
696 //kt if not FEditable then exit;
697 keybd_event(VK_SHIFT,0,0,0);
698 keybd_event(VK_RETURN,0,0,0);
699 keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
700 Handled:=true;
701 end;
702 Ord('B') : if CtrlToBeProcessed then begin
703 //kt if not FEditable then exit;
704 ToggleBold;
705 Handled:=true;
706 exit;
707 end;
708 Ord('U') : if CtrlToBeProcessed then begin
709 //kt if not FEditable then exit;
710 ToggleUnderline;
711 Handled:=true;
712 exit;
713 end;
714 Ord('I') : if CtrlToBeProcessed then begin
715 //kt if not FEditable then exit;
716 ToggleItalic;
717 Handled:=true;
718 end;
719 end; {case}
720 end;
721 WM_KEYUP : begin
722 case Msg.WParam of
723 VK_CONTROL : begin
724 CtrlToBeProcessed:=false;
725 Handled:=true;
726 if CtrlReturnToBeProcessed then begin
727 PostMessage(Msg.hwnd, WM_KEYDOWN, VK_RETURN, 0);
728 end;
729 exit;
730 end;
731 VK_SHIFT : begin
732 ShiftToBeProcessed:=false;
733 Handled:=true;
734 exit;
735 end;
736
737 end; {case}
738 //messagedlg('I''m Am Not Active', mtWarning,mbOKCancel,0);
739 exit;
740
741 end;
742 end; {case}
743 end;
744
745procedure THtmlObj.SetHTMLText(Html : String);
746//After this command, Copy and Paste will not work -- ?? why? Still true??
747var V : OleVariant;
748 V2 : variant;
749 body : IHTMLElement;
750 status : string;
751 temp : string;
752begin
753 try
754 Stop;
755 TheDoc:=Document as IHTMLDocument2;
756 if TheDoc=nil then exit;
757 body := TheDoc.body;
758
759 if UpperCase(TheDoc.designMode) <> 'ON' then begin
760 TheDoc.designMode := 'on';
761 repeat //NOTE: potential endless loop. Perhaps loop only status='loading'?
762 status := TheDoc.readyState;
763 {Possible status values:
764 uninitialized -- Object is not initialized with data.
765 loading -- Object is loading its data.
766 loaded -- Object has finished loading its data.
767 interactive -- User can interact with the object even though it is not fully loaded.
768 complete -- Object is completely initialized. }
769 if status <> 'complete' then FApplication.ProcessMessages;
770 until (status = 'complete') or (status='interactive') or (status='loaded');
771 end;
772 body := TheDoc.body;
773 if (body = nil) then begin //Do so stuff to get IE to make a 'body'.
774 V2 := VarArrayCreate([0, 0], VarVariant);
775 V2[0] := ' '; //Html;
776 TheDoc.Write(PSafeArray(System.TVarData(V2).VArray));
777 body := TheDoc.body;
778 TheDoc.close;
779 repeat
780 status := TheDoc.readyState; //For possible status values, see above)
781 if status <> 'complete' then FApplication.ProcessMessages;
782 until (status = 'complete') or (status='interactive') or (status='loaded');
783 body := TheDoc.body;
784 end;
785 body.innerHTML := Html;
786 temp := body.innerHTML; //to test if it was set or not...
787 Modified:=true;
788 except
789 on E:Exception do EError('Error setting HTML text',E);
790 end;
791end;
792
793(*
794procedure THtmlObj.SetHTMLText(Html : String);
795//After this command, Copy and Paste will not work -- ?? why? Still true??
796var V : OleVariant;
797 V2 : variant;
798 status : string;
799begin
800 try
801 if (TheDoc=nil) or (TheDoc.body=nil) then begin
802 Stop;
803 V := Document;// as IHTMLDocument2;
804 V.Open;
805 V.Clear;
806 V.Write(Html);
807 V.Close;
808 //Fix: Need a way to set font and size in this operation...
809 end else begin
810 TheDoc.body.innerHTML := Html;
811 end;
812 Modified:=true;
813 except
814 on E:Exception do EError('Error setting HTML text',E);
815 end;
816end;
817*)
818
819function THtmlObj.GetHTMLText:string;
820var WS:WideString;
821 ch:WideChar;
822 n:integer;
823 w:word;
824 s:string;
825begin
826 Result:='';
827 if TheDoc=nil then exit;
828 WS:=TheDoc.body.innerHTML;
829 for n:=1 to length(WS) do begin
830 ch:=WS[n];
831 w:=word(ch);
832 if w>255 then begin
833 s:=IntToStr(w);
834 s:='&#'+s+';';
835 end else s:=ch;
836 Result:=Result+s;
837 end;
838end;
839
840function THtmlObj.GetText:string;
841var WS:WideString;
842 ch:WideChar;
843 n:integer;
844 w:word;
845 s:string;
846begin
847 Result:='';
848 if TheDoc=nil then exit;
849 WS:=TheDoc.body.innerText;
850 for n:=1 to length(WS) do begin
851 ch:=WS[n];
852 w:=word(ch);
853 if w>255 then begin
854 w:=(w mod 256)+48;
855 s:=IntToStr(w);
856 s:=char(w);
857 end else s:=ch;
858 Result:=Result+s;
859 end;
860end;
861
862procedure THtmlObj.SetText(HTML:string);
863begin
864 if (TheDoc=nil)or(TheDoc.body=nil) then SetHTMLText(HTML)
865 else TheDoc.body.innerHTML:=HTML;
866end;
867
868function THtmlObj.GetTextLen : integer;
869begin
870 Result := Length(GetText);
871end;
872
873procedure THtmlObj.Clear;
874begin
875 SetHTMLText('');
876 SetDefaultFont;
877end;
878
879function THtmlObj.SelStart:integer;
880var TextRange:IHtmlTxtRange;
881begin
882 Result:=0;
883 TextRange:=GetTextRange;
884 if TextRange=nil then exit;
885 Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
886end;
887
888function THtmlObj.SelEnd:integer;
889var TextRange:IHtmlTxtRange;
890begin
891 Result:=0;
892 TextRange:=GetTextRange;
893 if TextRange=nil then exit;
894 Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
895end;
896
897function THtmlObj.SelLength:integer;
898begin
899 Result:=SelEnd-SelStart;
900end;
901
902function THtmlObj.GetTextRange:IHtmlTxtRange;
903begin
904 Result:=nil;
905 try
906 if TheDoc=nil then exit;
907 while TheDoc.body=nil do begin
908 WaitLoad(true);
909 if TheDoc.body=nil then begin
910 if MessageDlg('Wait for document loading?',mtConfirmation,
911 [mbOK,mbCancel],0) <> mrOK then begin
912 exit;
913 end;
914 end;
915 end;
916 if (TheDoc.Selection.type_='Text') or (TheDoc.Selection.type_='None') then begin
917 Result:=TheDoc.Selection.CreateRange as IHtmlTxtRange;
918 end;
919 except
920 on E:Exception do EError('This type of selection cannot be processed',E);
921 end;
922end;
923
924procedure THtmlObj.SetSelection(Start,Length:integer);
925var TextRange:IHtmlTxtRange;
926 l : integer ; //kt
927begin
928 try
929 if TheDoc=nil then exit;
930 TheDoc.Selection.Empty;
931 TextRange:=GetTextRange;
932 if TextRange=nil then exit;
933 TextRange.collapse(true);
934 l:=TextRange.moveEnd('character',Start+Length);
935 l:=TextRange.moveStart('character',Start);
936 TextRange.select;
937 except
938 on E:Exception do EError('Error setting HTML selection'+nl+
939 'Start='+IntToStr(Start)+nl+
940 'Length='+IntToStr(Length),E);
941 end;
942end;
943
944
945procedure THtmlObj.ClearSelection;
946begin
947 if TheDoc=nil then exit;
948 TheDoc.Selection.Clear;
949 Modified:=true;
950end;
951
952
953procedure THtmlObj.ReplaceSelection(HTML:string);
954var TextRange:IHtmlTxtRange;
955begin
956 try
957 TextRange:=GetTextRange;
958 if TextRange=nil then exit;
959 TextRange.PasteHTML(HTML);
960 Modified:=true;
961 except
962 on E:Exception do begin
963 // implement later... ShortenString(HTML,80);
964 EError('Error pasting HTML'+nl+
965 'Microsoft HTML refuses to paste this string:'+nl+
966 HTML+nl,E);
967 end;
968 end;
969end;
970
971
972function THtmlObj.GetSelText:string;
973var TextRange:IHtmlTxtRange;
974begin
975 Result:='';
976 TextRange:=GetTextRange;
977 if TextRange=nil then
978 exit;
979 Result:=TextRange.text;
980end;
981
982procedure THtmlObj.SetSelText (HTMLText : string);
983begin
984 ReplaceSelection(HTMLText);
985end;
986
987
988function THtmlObj.ColorToMSHTMLStr(color : TColor) : string;
989//Note: TColor stores colors lo-byte --> hi-byte as RGB
990//Function returns '#RRGGBB'
991var tempColor : TMGColor;
992begin
993 tempColor.Color := color;
994 Result := '#'+
995 IntToHex(tempColor.RGBColor.R,2)+
996 IntToHex(tempColor.RGBColor.G,2)+
997 IntToHex(tempColor.RGBColor.B,2);
998end;
999
1000function THtmlObj.MSHTMLStrToColor(MSHTMLColor : string) : TColor;
1001//Function converts '#RRGGBB' -- TColor
1002//Note: TColor stores colors lo-byte --> hi-byte as RGB
1003var tempColor : TMGColor;
1004 strHexRed,strHexGreen,strHexBlue : string[2];
1005begin
1006 Result := clBlack; //FIX!!!! IMPLEMENT LATER...
1007 if Pos('#',MSHTMLColor)=1 then begin
1008 // MSHTMLColor := MidStr(MSHTMLColor,2,99);
1009 strHexRed := MidStr(MSHTMLColor,2,2);
1010 strHexGreen := MidStr(MSHTMLColor,4,2);
1011 strHexBlue := MidStr(MSHTMLColor,6,2);
1012 tempColor.RGBColor.R := StrToIntDef('$'+StrHexRed,0);
1013 tempColor.RGBColor.G := StrToIntDef('$'+StrHexGreen,0);
1014 tempColor.RGBColor.B := StrToIntDef('$'+StrHexBlue,0);
1015 Result := tempColor.Color;
1016 //NOTE: This function has not yet been tested....
1017 end;
1018end;
1019
1020(*
1021procedure THtmlObj.SetBorder(Border:boolean);
1022begin
1023 if TheDoc=nil then exit;
1024 if TheDoc.body=nil then exit;
1025 if not Border then begin
1026 if not FEditable then begin
1027 TheDoc.body.style.backgroundColor := clYellow; //kt
1028 TheDoc.body.style.borderStyle:='none';
1029 TheDoc.body.style.borderWidth:='thin';
1030 TheDoc.body.style.borderColor:='white';
1031 end;
1032 if FEditable then begin
1033 TheDoc.body.style.backgroundColor := clRed; //kt
1034 TheDoc.body.style.borderStyle:='none';
1035// TheDoc.body.filters.
1036 TheDoc.body.style.borderWidth:='thin';
1037 TheDoc.body.style.borderColor:='blue';
1038 end;
1039 end;
1040 if Border then begin
1041 if not FEditable then begin
1042 TheDoc.body.style.borderStyle:='solid';
1043 TheDoc.body.style.borderWidth:='thin';
1044 TheDoc.body.style.borderColor:='silver';
1045 end;
1046 if FEditable then begin
1047 //TheDoc.body.style.backgroundColor := ColorToStr(clLime);
1048 TheDoc.body.style.backgroundColor := 'BtnFace';
1049 TheDoc.body.style.borderStyle:='solid';
1050 TheDoc.body.style.borderWidth:='thin';
1051 TheDoc.body.style.borderColor:='green';
1052 end;
1053 end;
1054end;
1055
1056
1057*)
1058
1059initialization
1060
1061finalization
1062
1063end.
1064
Note: See TracBrowser for help on using the repository browser.