source: cprs/branches/tmg-cprs/CPRS-Chart/TMG_Extra/HTMLEdit/TMGHTML.pas.bak@ 1766

Last change on this file since 1766 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 if not FCustKeyboardHandlerOn then exit;
644 if not ((Msg.Message=WM_KEYDOWN) or
645 (Msg.Message=WM_KEYUP) or
646 (Msg.Message=WM_RBUTTONUP) ) then exit; //Speedy exit of non-handled messages
647 case Msg.Message of
648 WM_RBUTTONUP : begin
649 Cursor := ScreenToClient(Msg.pt);
650 //Ignore message if mouse not over this HTML control
651 if (Cursor.X<0) or (Cursor.X>Width) or
652 (Cursor.Y<0) or (Cursor.Y>Height) then exit;
653 if CtrlToBeProcessed then begin
654 CtrlToBeProcessed := false;
655 exit; //Ctrl-right click is ignored
656 end;
657 if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
658 Handled:=true;
659 exit;
660 end;
661 WM_KEYDOWN : begin
662 case Msg.WParam of
663 VK_CONTROL : begin
664 CtrlToBeProcessed:=true;
665 Handled:=true;
666 exit;
667 end;
668 VK_SHIFT : begin
669 ShiftToBeProcessed:=true;
670 Handled:=true;
671 exit;
672 end;
673 VK_TAB : begin
674 //kt if not FEditable then exit;
675 if ShiftToBeProcessed then begin
676 for i := 0 to 5 do begin
677 PostMessage(Msg.hwnd, WM_KEYDOWN, VK_LEFT, 0);
678 end;
679 end else begin
680 for i := 0 to 5 do begin
681 PostMessage(Msg.hwnd, WM_KEYDOWN, VK_SPACE, 0);
682 end;
683 end;
684 Handled:=true;
685 end;
686 VK_RETURN : if CtrlReturnToBeProcessed then begin
687 Handled:=false;
688 CtrlReturnToBeProcessed := false;
689 end else if CtrlToBeProcessed then begin
690 Handled:=true;
691 CtrlToBeProcessed := False;
692 CtrlReturnToBeProcessed := true;
693 //PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);
694 end else if ShiftToBeProcessed=false then begin
695 //kt if not FEditable then exit;
696 keybd_event(VK_SHIFT,0,0,0);
697 keybd_event(VK_RETURN,0,0,0);
698 keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
699 Handled:=true;
700 end;
701 Ord('B') : if CtrlToBeProcessed then begin
702 //kt if not FEditable then exit;
703 ToggleBold;
704 Handled:=true;
705 exit;
706 end;
707 Ord('U') : if CtrlToBeProcessed then begin
708 //kt if not FEditable then exit;
709 ToggleUnderline;
710 Handled:=true;
711 exit;
712 end;
713 Ord('I') : if CtrlToBeProcessed then begin
714 //kt if not FEditable then exit;
715 ToggleItalic;
716 Handled:=true;
717 end;
718 end; {case}
719 end;
720 WM_KEYUP : begin
721 case Msg.WParam of
722 VK_CONTROL : begin
723 CtrlToBeProcessed:=false;
724 Handled:=true;
725 if CtrlReturnToBeProcessed then begin
726 PostMessage(Msg.hwnd, WM_KEYDOWN, VK_RETURN, 0);
727 end;
728 exit;
729 end;
730 VK_SHIFT : begin
731 ShiftToBeProcessed:=false;
732 Handled:=true;
733 exit;
734 end;
735
736 end; {case}
737 //messagedlg('I''m Am Not Active', mtWarning,mbOKCancel,0);
738 exit;
739
740 end;
741 end; {case}
742 end;
743
744procedure THtmlObj.SetHTMLText(Html : String);
745//After this command, Copy and Paste will not work -- ?? why? Still true??
746var V : OleVariant;
747 V2 : variant;
748 body : IHTMLElement;
749 status : string;
750 temp : string;
751begin
752 try
753 Stop;
754 TheDoc:=Document as IHTMLDocument2;
755 if TheDoc=nil then exit;
756 body := TheDoc.body;
757
758 if UpperCase(TheDoc.designMode) <> 'ON' then begin
759 TheDoc.designMode := 'on';
760 repeat //NOTE: potential endless loop. Perhaps loop only status='loading'?
761 status := TheDoc.readyState;
762 {Possible status values:
763 uninitialized -- Object is not initialized with data.
764 loading -- Object is loading its data.
765 loaded -- Object has finished loading its data.
766 interactive -- User can interact with the object even though it is not fully loaded.
767 complete -- Object is completely initialized. }
768 if status <> 'complete' then FApplication.ProcessMessages;
769 until (status = 'complete') or (status='interactive') or (status='loaded');
770 end;
771 body := TheDoc.body;
772 if (body = nil) then begin //Do so stuff to get IE to make a 'body'.
773 V2 := VarArrayCreate([0, 0], VarVariant);
774 V2[0] := ' '; //Html;
775 TheDoc.Write(PSafeArray(System.TVarData(V2).VArray));
776 body := TheDoc.body;
777 TheDoc.close;
778 repeat
779 status := TheDoc.readyState; //For possible status values, see above)
780 if status <> 'complete' then FApplication.ProcessMessages;
781 until (status = 'complete') or (status='interactive') or (status='loaded');
782 body := TheDoc.body;
783 end;
784 body.innerHTML := Html;
785 temp := body.innerHTML; //to test if it was set or not...
786 Modified:=true;
787 except
788 on E:Exception do EError('Error setting HTML text',E);
789 end;
790end;
791
792(*
793procedure THtmlObj.SetHTMLText(Html : String);
794//After this command, Copy and Paste will not work -- ?? why? Still true??
795var V : OleVariant;
796 V2 : variant;
797 status : string;
798begin
799 try
800 if (TheDoc=nil) or (TheDoc.body=nil) then begin
801 Stop;
802 V := Document;// as IHTMLDocument2;
803 V.Open;
804 V.Clear;
805 V.Write(Html);
806 V.Close;
807 //Fix: Need a way to set font and size in this operation...
808 end else begin
809 TheDoc.body.innerHTML := Html;
810 end;
811 Modified:=true;
812 except
813 on E:Exception do EError('Error setting HTML text',E);
814 end;
815end;
816*)
817
818function THtmlObj.GetHTMLText:string;
819var WS:WideString;
820 ch:WideChar;
821 n:integer;
822 w:word;
823 s:string;
824begin
825 Result:='';
826 if TheDoc=nil then exit;
827 WS:=TheDoc.body.innerHTML;
828 for n:=1 to length(WS) do begin
829 ch:=WS[n];
830 w:=word(ch);
831 if w>255 then begin
832 s:=IntToStr(w);
833 s:='&#'+s+';';
834 end else s:=ch;
835 Result:=Result+s;
836 end;
837end;
838
839function THtmlObj.GetText:string;
840var WS:WideString;
841 ch:WideChar;
842 n:integer;
843 w:word;
844 s:string;
845begin
846 Result:='';
847 if TheDoc=nil then exit;
848 WS:=TheDoc.body.innerText;
849 for n:=1 to length(WS) do begin
850 ch:=WS[n];
851 w:=word(ch);
852 if w>255 then begin
853 w:=(w mod 256)+48;
854 s:=IntToStr(w);
855 s:=char(w);
856 end else s:=ch;
857 Result:=Result+s;
858 end;
859end;
860
861procedure THtmlObj.SetText(HTML:string);
862begin
863 if (TheDoc=nil)or(TheDoc.body=nil) then SetHTMLText(HTML)
864 else TheDoc.body.innerHTML:=HTML;
865end;
866
867function THtmlObj.GetTextLen : integer;
868begin
869 Result := Length(GetText);
870end;
871
872procedure THtmlObj.Clear;
873begin
874 SetHTMLText('');
875 SetDefaultFont;
876end;
877
878function THtmlObj.SelStart:integer;
879var TextRange:IHtmlTxtRange;
880begin
881 Result:=0;
882 TextRange:=GetTextRange;
883 if TextRange=nil then exit;
884 Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
885end;
886
887function THtmlObj.SelEnd:integer;
888var TextRange:IHtmlTxtRange;
889begin
890 Result:=0;
891 TextRange:=GetTextRange;
892 if TextRange=nil then exit;
893 Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
894end;
895
896function THtmlObj.SelLength:integer;
897begin
898 Result:=SelEnd-SelStart;
899end;
900
901function THtmlObj.GetTextRange:IHtmlTxtRange;
902begin
903 Result:=nil;
904 try
905 if TheDoc=nil then exit;
906 while TheDoc.body=nil do begin
907 WaitLoad(true);
908 if TheDoc.body=nil then begin
909 if MessageDlg('Wait for document loading?',mtConfirmation,
910 [mbOK,mbCancel],0) <> mrOK then begin
911 exit;
912 end;
913 end;
914 end;
915 if (TheDoc.Selection.type_='Text') or (TheDoc.Selection.type_='None') then begin
916 Result:=TheDoc.Selection.CreateRange as IHtmlTxtRange;
917 end;
918 except
919 on E:Exception do EError('This type of selection cannot be processed',E);
920 end;
921end;
922
923procedure THtmlObj.SetSelection(Start,Length:integer);
924var TextRange:IHtmlTxtRange;
925 l : integer ; //kt
926begin
927 try
928 if TheDoc=nil then exit;
929 TheDoc.Selection.Empty;
930 TextRange:=GetTextRange;
931 if TextRange=nil then exit;
932 TextRange.collapse(true);
933 l:=TextRange.moveEnd('character',Start+Length);
934 l:=TextRange.moveStart('character',Start);
935 TextRange.select;
936 except
937 on E:Exception do EError('Error setting HTML selection'+nl+
938 'Start='+IntToStr(Start)+nl+
939 'Length='+IntToStr(Length),E);
940 end;
941end;
942
943
944procedure THtmlObj.ClearSelection;
945begin
946 if TheDoc=nil then exit;
947 TheDoc.Selection.Clear;
948 Modified:=true;
949end;
950
951
952procedure THtmlObj.ReplaceSelection(HTML:string);
953var TextRange:IHtmlTxtRange;
954begin
955 try
956 TextRange:=GetTextRange;
957 if TextRange=nil then exit;
958 TextRange.PasteHTML(HTML);
959 Modified:=true;
960 except
961 on E:Exception do begin
962 // implement later... ShortenString(HTML,80);
963 EError('Error pasting HTML'+nl+
964 'Microsoft HTML refuses to paste this string:'+nl+
965 HTML+nl,E);
966 end;
967 end;
968end;
969
970
971function THtmlObj.GetSelText:string;
972var TextRange:IHtmlTxtRange;
973begin
974 Result:='';
975 TextRange:=GetTextRange;
976 if TextRange=nil then
977 exit;
978 Result:=TextRange.text;
979end;
980
981procedure THtmlObj.SetSelText (HTMLText : string);
982begin
983 ReplaceSelection(HTMLText);
984end;
985
986
987function THtmlObj.ColorToMSHTMLStr(color : TColor) : string;
988//Note: TColor stores colors lo-byte --> hi-byte as RGB
989//Function returns '#RRGGBB'
990var tempColor : TMGColor;
991begin
992 tempColor.Color := color;
993 Result := '#'+
994 IntToHex(tempColor.RGBColor.R,2)+
995 IntToHex(tempColor.RGBColor.G,2)+
996 IntToHex(tempColor.RGBColor.B,2);
997end;
998
999function THtmlObj.MSHTMLStrToColor(MSHTMLColor : string) : TColor;
1000//Function converts '#RRGGBB' -- TColor
1001//Note: TColor stores colors lo-byte --> hi-byte as RGB
1002var tempColor : TMGColor;
1003 strHexRed,strHexGreen,strHexBlue : string[2];
1004begin
1005 Result := clBlack; //FIX!!!! IMPLEMENT LATER...
1006 if Pos('#',MSHTMLColor)=1 then begin
1007 // MSHTMLColor := MidStr(MSHTMLColor,2,99);
1008 strHexRed := MidStr(MSHTMLColor,2,2);
1009 strHexGreen := MidStr(MSHTMLColor,4,2);
1010 strHexBlue := MidStr(MSHTMLColor,6,2);
1011 tempColor.RGBColor.R := StrToIntDef('$'+StrHexRed,0);
1012 tempColor.RGBColor.G := StrToIntDef('$'+StrHexGreen,0);
1013 tempColor.RGBColor.B := StrToIntDef('$'+StrHexBlue,0);
1014 Result := tempColor.Color;
1015 //NOTE: This function has not yet been tested....
1016 end;
1017end;
1018
1019(*
1020procedure THtmlObj.SetBorder(Border:boolean);
1021begin
1022 if TheDoc=nil then exit;
1023 if TheDoc.body=nil then exit;
1024 if not Border then begin
1025 if not FEditable then begin
1026 TheDoc.body.style.backgroundColor := clYellow; //kt
1027 TheDoc.body.style.borderStyle:='none';
1028 TheDoc.body.style.borderWidth:='thin';
1029 TheDoc.body.style.borderColor:='white';
1030 end;
1031 if FEditable then begin
1032 TheDoc.body.style.backgroundColor := clRed; //kt
1033 TheDoc.body.style.borderStyle:='none';
1034// TheDoc.body.filters.
1035 TheDoc.body.style.borderWidth:='thin';
1036 TheDoc.body.style.borderColor:='blue';
1037 end;
1038 end;
1039 if Border then begin
1040 if not FEditable then begin
1041 TheDoc.body.style.borderStyle:='solid';
1042 TheDoc.body.style.borderWidth:='thin';
1043 TheDoc.body.style.borderColor:='silver';
1044 end;
1045 if FEditable then begin
1046 //TheDoc.body.style.backgroundColor := ColorToStr(clLime);
1047 TheDoc.body.style.backgroundColor := 'BtnFace';
1048 TheDoc.body.style.borderStyle:='solid';
1049 TheDoc.body.style.borderWidth:='thin';
1050 TheDoc.body.style.borderColor:='green';
1051 end;
1052 end;
1053end;
1054
1055
1056*)
1057
1058initialization
1059
1060finalization
1061
1062end.
1063
Note: See TracBrowser for help on using the repository browser.