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

unit TMGHTML;

(*
NOTES:  By Kevin Toppenberg, MD 5/27/09

Code heavily modified from original code found at www.supermemo.com/source/
Their notes (below) indicate that the code may be freely used.

This unit encapsulates SHDocVw.dll and MSHTML.dll functionality by subclassing
THtmlEditorBrowser object as THtmlEditor object

THtmlEditor was designed for easy use of HTML display and editing capacity in
SuperMemo 2002 for Windows developed by SuperMemo R&D in Fall 2001.

SuperMemo 2002 implements HTML-based incremental reading in which extensive HTML
support is vital.

Pieces of this units can be used by anyone in other Delphi applications that make
use of HTML WYSIWYG interfaces made open by Microsoft.
*)


interface

uses SysUtils, WinTypes, Dialogs, StdCtrls, Menus,
     EmbeddedED,
     ActiveX, MSHTMLEvents, SHDocVw, {MSHTML,} MSHTML_EWB,
     AppEvnts,
     IeConst,Messages,Classes,Forms,Graphics;

const
  CGID_MSHTML:TGUID='{DE4BA900-59CA-11CF-9592-444553540000}';
  IID_IOleCommandTarget:TGUID='{B722BCCB-4E68-101B-A2BC-00AA00404770}';
  CGID_WebBrowser:TGUID='{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
  FontScale=3;  

type  
  TSetFontMode = (sfAll,sfSize,sfColor,sfName,sfStyle,sfCharset); 

  TRGBColor = record
       R : byte; 
       G : byte;
       B : byte;
  end; {record}
  
  TMGColor = record
    case boolean of
      True: (Color : TColor);
      False: (RGBColor : TRGBColor);
  end; {record}
                               
type 
     // THtmlObj=class(TWebBrowser)
     THtmlObj=class(TEmbeddedED)
     private
       FEditable:               boolean;
       Modified:                boolean;
       DocEvents:               TMSHTMLHTMLDocumentEvents;   //elh
       WinEvents:               TMSHTMLHTMLWindowEvents2;
       CtrlReturnToBeProcessed: boolean;
       CtrlToBeProcessed  :     boolean;
       ShiftToBeProcessed :     boolean;
       ColorDialog:             TColorDialog;       
       FOrigAppOnMessage :      TMessageEvent;  
       FCustKeyboardHandlerOn:  boolean;
       FActive :                boolean;
       FApplication :           TApplication;
       procedure WaitLoad(peek:boolean);
       function  GetEditableState : boolean;
       procedure SetEditableState (EditOn : boolean);         
       procedure SetBackgroundColor(Color:TColor);
       function  GetBackgroundColor : TColor;       
       procedure SetTextBackgroundColor(Color:TColor);
       function  GetTextBackgroundColor : TColor;
       procedure SetTextForegroundColor(Color:TColor);
       function  GetTextForegroundColor : TColor; 
       function  GetFontSize : integer;
       procedure SetFontSize (Size : integer);                   
       function  GetFontName : string;
       procedure SetFontName (Name : string);
       procedure SetActive (Active : boolean);
       function  GetHTMLText:string;
       procedure SetHTMLText(HTML:String);
       function  GetText:string;
       procedure SetText(HTML:string);       
       function  GetSelText:string;        
       procedure SetSelText (HTMLText : string); 
       procedure DefineDocEvents;  //elh   
       procedure DefineWinEvents;  
       procedure OnDocFocusOut(Sender:TObject);  //elh   

       procedure SetDefaultFont;
       function ColorToMSHTMLStr(color : TColor) : string; 
       function MSHTMLStrToColor(MSHTMLColor : string) : TColor;
       
       //Events ------------------
       procedure NavigateComplete2(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
       procedure LocalMessageHandler(var Msg: TMsg; var Handled: Boolean);
       procedure CompleteLoading;              
       procedure ProcessLoadMessages;
       function  SpecialCommand(Cmd : Cardinal; PromptUser : boolean;
                   editModeOnly : boolean; bTriEditCommandGroup : boolean;
                   InputArgs : OleVariant) : HRESULT;
       function  HrExecCommand(ucmdID: cardinal;
                   const pVarIn: OleVariant; var pVarOut: OleVariant; bPromptUser,
                   bTriEditCmdGroup: boolean): HResult;
        procedure ReassignKeyboardHandler(TurnOn : boolean);
       {end private}
      public
        TheDoc:        IHTMLDocument2; //MSHTML HTML Document 2 interface
//        HTMLEvents:    HTMLWindowsEvents2;
        TheWind:       IHTMLWindow2;
        DocCmd,WebCmd: IOleCommandTarget; //MSHTML IOLECommandTarget interface
        PopupMenu:     TPopupMenu;
        DefaultFontSize : Integer;
        DefaultFontName : string;
        constructor Create(Owner:TComponent; Application : TApplication); 
        destructor Destroy; override;
        //Properties --- 
        property Editable : boolean read GetEditableState write SetEditableState;
        property BackgroundColor : TColor read GetBackgroundColor write SetBackgroundColor;
        property TextBackgroundColor : TColor read GetTextBackgroundColor write SetTextBackgroundColor;
        property TextForegroundColor : TColor read GetTextForegroundColor write SetTextForegroundColor;
        property FontSize : integer read GetFontSize write SetFontSize;
        property FontName : string read GetFontName write SetFontName;
        property HTMLText:string read GetHTMLText write SetHTMLText;
        property Text:string read GetText write SetText;
        property Active : boolean read FActive write SetActive;
        property SelText : string read GetSelText write SetSelText;
        //Methods -------        
        function GetTextLen : integer;
        procedure Clear;
        procedure LoadFile(FileName:string);         

        procedure ToggleBullet;
        procedure ToggleItalic;
        procedure ToggleBold;         
        procedure ToggleNumbering;
        procedure ToggleUnderline;
        procedure ToggleSubscript;
        procedure ToggleSuperscript;
        procedure Indent;
        procedure Outdent;
        procedure AlignLeft;
        procedure AlignRight;
        procedure AlignCenter;
        procedure FontDialog;
        procedure TextForeColorDialog;
        procedure TextBackColorDialog;

        procedure SetSelection(Start,Length:integer);
        function GetTextRange:IHtmlTxtRange;
        function SelStart:integer;
        function SelEnd:integer;
        function SelLength:integer;
        
        procedure ClearSelection;
        procedure ReplaceSelection(HTML:string);
        {end public}
      end;

type THtmlEditor=class(THtmlObj);

implementation


uses 
  WinProcs,Controls,Variants,Clipbrd, StrUtils;

const
  MaxTextLength = 100;
  nl = #13#10;
  
procedure EError(EText : string; E : Exception);
begin
  MessageDlg(EText,mtError,[mbOK],0);
end;

constructor THtmlObj.Create(Owner:TComponent; Application : TApplication);
begin
  inherited Create(Owner);
  TheDoc:=nil;
  DocCmd:=nil;
  WebCmd:=nil;
  ColorDialog := nil;
  FApplication := Application;
  FOrigAppOnMessage := Application.OnMessage;
  FEditable := false;  
  DefaultFontSize := 10;
  OnBlur := OnDocFocusOut;
  DefaultFontName := 'Times New Roman';
  FCustKeyboardHandlerOn := false;
  OnNavigateComplete2 := NavigateComplete2;
end;

destructor THtmlObj.Destroy;
begin
  SetActive(false); // ReassignKeyboardHandler(false);
  ColorDialog.Free;
  inherited Destroy;
end;


procedure THtmlObj.LoadFile(FileName:string);
var OldWidth,OldHeight:integer;
begin
  try
     self.Cursor := crHourGlass; 
     OldHeight:=Height;
     OldWidth:=Width;
     Navigate(FileName);
     Width:=OldWidth; {due to a bug that sizes down HTML components on start}{Oct 15, 2001}
     Height:=OldHeight;
     TheDoc:=nil;
     if DocCmd<>nil then begin
       DocCmd._Release;
       DocCmd:=nil;
     end;
     WaitLoad(true); //kt
     self.Cursor := crDefault; //kt     
  except
    on E:Exception do begin
     EError('Cannot load '+Filename,E);
    end;
  end;
end;


procedure THtmlObj.WaitLoad(peek:boolean);
begin
  try
     TheDoc:=Document as IHTMLDocument2;
     while TheDoc=nil do begin
       if peek then ProcessLoadMessages
       else exit;
       TheDoc:=Document as IHTMLDocument2;
     end;

     repeat
       ControlInterface.QueryInterface(IID_IOleCommandTarget,WebCmd);
     until WebCmd<>nil;

     repeat
       TheDoc.QueryInterface(IOleCommandTarget,DocCmd);
     until DocCmd<>nil;

     repeat
       TheWind:=TheDoc.parentWindow;
     until TheWind<>nil;

     while (TheDoc=nil)or((theDoc.ReadyState<>'complete')and(theDoc.ReadyState<>'interactive')) do begin
       {remove messages that should not be processed while the element is loading}
       {TheDoc can become nil when switching applications!}
       if TheDoc=nil then
         MessageBeep(0); {this beep is sounded while page is loading while control is no longer in forefront}
       if peek then
         ProcessLoadMessages
       else
         exit;
     end;
     
  except
    on E:Exception do EError('Error loading the document',E);
  end;
end;


procedure THtmlObj.ProcessLoadMessages;
var msg:TMsg;
    MessageQueue:array of TMsg;
    m:integer;
begin
  while PeekMessage(msg,0,wm_KeyFirst,wm_KeyLast,pm_Remove) do; {remove keyboard input first}
  while PeekMessage(msg,0,wm_MouseFirst,wm_MouseLast,pm_Remove) do; {remove mouse input}
  while PeekMessage(msg,0,wm_Close,wm_Close,pm_Remove) do; {disallow closing the application}
  while PeekMessage(msg,0,wm_ActivateApp,wm_ActivateApp,pm_Remove) do; {disallow activating the application}
  //ktwhile PeekMessage(msg,0,wm_User,cm_LastUserMessage,pm_Remove) do begin
  while PeekMessage(msg,0,wm_User,wm_User+$200,pm_Remove) do begin
        SetLength(MessageQueue,length(MessageQueue)+1);
        MessageQueue[length(MessageQueue)-1]:=msg;
        end;
  forms.Application.ProcessMessages; {process messages needed to complete navigation}
  for m:=1 to length(MessageQueue) do begin
      msg:=MessageQueue[m-1];
      PostMessage(msg.hwnd,msg.message,msg.WParam,msg.lParam);
      end;
end;

function THtmlObj.SpecialCommand(Cmd:Cardinal;PromptUser:boolean;
                              editModeOnly:boolean;bTriEditCommandGroup:boolean;
                              InputArgs:OleVariant):HRESULT;
begin
  Result:=HrExecCommand(Cmd,null,InputArgs,promptUser,bTriEditCommandGroup);
end;


function THtmlObj.HrExecCommand(ucmdID: cardinal; const pVarIn: OleVariant; 
                                var pVarOut: OleVariant; bPromptUser,
                                bTriEditCmdGroup: boolean): HResult;
var dwCmdOpt:DWORD;
begin
   result := S_OK;
   if DocCmd = nil then Exit;
   if (bPromptUser) then dwCmdOpt := MSOCMDEXECOPT_PROMPTUSER
   else dwCmdOpt := MSOCMDEXECOPT_DONTPROMPTUSER;
   if (bTriEditCmdGroup) then
     result := DocCmd.Exec(@GUID_TriEditCommandGroup,ucmdID,dwCmdOpt,pVarIn,pVarOut)
   else
     result := DocCmd.Exec(@CMDSETID_Forms3,ucmdID,dwCmdOpt,pVarIn,pVarOut);
end;

procedure THtmlObj.SetDefaultFont;
begin
  if DefaultFontName <> '' then SetFontName(DefaultFontName);
  if DefaultFontSize <> 0 then SetFontSize(DefaultFontSize);
end;


function THtmlObj.GetEditableState : boolean;
var mode : string;
begin
  mode := TheDoc.designMode;
  result := (mode = 'On');
end;

procedure THtmlObj.SetEditableState(EditOn : boolean);
var LastMode : string;
    count : integer;
begin
  LastMode := 'Inherit';
  try
    count := 0;
    repeat
      inc (count);
      if TheDoc = nil then begin
        FApplication.ProcessMessages;
        Sleep (100);
        continue;
      end else if TheDoc.body = nil then begin
        FApplication.ProcessMessages;
        Sleep (100);
        continue;
      end;  
      if EditOn then begin
        TheDoc.body.setAttribute('contentEditable','true',0);
        TheDoc.designMode := 'On';  //kt
        FEditable:=true;
        //SetFocus;
      end else begin
        TheDoc.body.setAttribute('contentEditable','false',0);
        TheDoc.designMode := 'Off';  //kt
        FEditable:=false;
      end;  
      LastMode := TheDoc.designMode;
    until (LastMode <> 'Inherit') or (count > 20);  
  except
    on E:Exception do EError('Error switching into HTML editing state',E);
  end;
end;

procedure THtmlObj.ToggleBullet;
begin
  if TheDoc=nil then exit;
  //SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
  TheDoc.execCommand('InsertUnorderedList',false,null);  
  Modified:=true;
end;

procedure THtmlObj.ToggleItalic;
begin
  if TheDoc=nil then exit;
  //SpecialCommand(IDM_UnORDERLIST,false,true,false,Null);
  TheDoc.execCommand('Italic',false,null);  
  Modified:=true;
end;

procedure THtmlObj.ToggleBold;
begin
  if TheDoc=nil then exit;
  TheDoc.execCommand('Bold',false,null);
  Modified:=true;
end;

procedure THtmlObj.ToggleNumbering;
begin
  if TheDoc=nil then exit;
  TheDoc.execCommand('InsertOrderedList',false,null);
//  SpecialCommand(IDM_ORDERLIST,false,true,false,Null);
  Modified:=true;
end;

procedure THtmlObj.ToggleUnderline;
begin
   if TheDoc=nil then exit;
   TheDoc.execCommand('Underline',false,null);
  Modified:=true;
end;

procedure THtmlObj.ToggleSubscript;
begin
  if TheDoc=nil then exit;
  TheDoc.execCommand('Subscript',False,0);
  Modified:=true;
end;

procedure THtmlObj.ToggleSuperscript;
begin
  if TheDoc=nil then exit;
  TheDoc.execCommand('Superscript',False,0);
  Modified:=true;
end;


procedure THtmlObj.Indent;
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('Indent',false,0);
  Modified:=true;
end;

procedure THtmlObj.Outdent;
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('Outdent',false,0);
  Modified:=true;
end;


procedure THtmlObj.AlignLeft;
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('JustifyLeft',false,0);
  Modified:=true;
end;

procedure THtmlObj.AlignRight;
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('JustifyRight',false,0);
  Modified:=true;
end;

procedure THtmlObj.AlignCenter;
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('JustifyCenter',false,0);
  Modified:=true;
end;


procedure THtmlObj.SetBackgroundColor(Color:TColor);
begin
  if TheDoc=nil then exit;
  WaitLoad(true); //kt  
  if TheDoc.body=nil then exit;
  TheDoc.body.style.backgroundColor := ColorToMSHTMLStr(Color);
end;

function  THtmlObj.GetBackgroundColor : TColor;       
begin
  Result := clBlack; //default;
  if TheDoc=nil then exit;
  if TheDoc.body=nil then exit;
  Result := MSHTMLStrToColor(TheDoc.body.style.backgroundColor);
end;

procedure THtmlObj.TextForeColorDialog;
begin
  if ColorDialog = nil then begin
    ColorDialog := TColorDialog.Create(self);
  end;
  if ColorDialog.Execute then begin
    SetTextForegroundColor(ColorDialog.Color);
  end;  
  Modified:=true;
end;

procedure THtmlObj.TextBackColorDialog;
begin
  if ColorDialog = nil then begin
    ColorDialog := TColorDialog.Create(self);
  end;
  if ColorDialog.Execute then begin
    SetTextBackgroundColor(ColorDialog.Color);
  end;  
  Modified:=true;
end;

procedure THtmlObj.SetTextBackgroundColor(Color:TColor);
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('BackColor',false,Color);
  Modified:=true;
end;

function THtmlObj.GetTextBackgroundColor:TColor;
var Background :  OleVariant;
    vt         :  TVarType;
begin
  Result:=clWindow;
  try
    if TheDoc=nil then exit;
    Background:=TheDoc.queryCommandValue('BackColor');
    vt:=varType(Background);
    if vt<>varNull then Result:=Background;
  except
    on E:Exception do EError('Error retrieving background color',E);
  end;
end;

procedure THtmlObj.SetTextForegroundColor(Color:TColor);
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('ForeColor',false,Color);
  Modified:=true;
end;

function THtmlObj.GetTextForegroundColor:TColor;
var Background :  OleVariant;
    vt         :  TVarType;
begin
  Result:=clWindow;
  try
    if TheDoc=nil then exit;
    Background:=TheDoc.queryCommandValue('ForeColor');
    vt:=varType(Background);
    if vt<>varNull then Result:=Background;
  except
    on E:Exception do EError('Error retrieving foreground color',E);
  end;
end;

procedure THtmlObj.FontDialog;
begin
  SpecialCommand(IDM_FONT,True,True,False,Null);
  Modified:=true;
end;

function THtmlObj.GetFontSize : integer;
var FontSize : OleVariant;
    vt       : TVarType;
begin
  FontSize:=TheDoc.queryCommandValue('FontSize');
  vt:=varType(FontSize);
  if vt<>varNull then Result := FontSize*FontScale
  else Result :=12*FontScale; //kt
end;

procedure THtmlObj.SetFontSize (Size : integer);
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('FontSize', false, Size div FontScale);
end;

function THtmlObj.GetFontName : string;
var FontName :OleVariant;
    vt : TVarType;
begin
  if TheDoc=nil then exit;
  FontName:=TheDoc.queryCommandValue('FontName');
  vt:=varType(FontName);
  if vt<>varNull then Result := FontName
  else Result :='Times New Roman'; //kt
end;

procedure THtmlObj.SetFontName (Name : string);
begin
  if TheDoc=nil then exit;
  TheDoc.ExecCommand('FontName', false, Name);
end;

procedure THtmlObj.SetActive (Active : boolean);
//NOTE: This object grabs the OnMessage for the entire application, so that 
//      it can intercept the right-click.  As a result, the object needs a
//      way that it can turn off this feature when it is covered up by other
//      windows application subwindows etc.  This function provides this.
begin
  FActive := Active;
  ReassignKeyboardHandler(FActive);
end;


procedure THtmlObj.NavigateComplete2(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
begin
  CompleteLoading;
end;

procedure THtmlObj.CompleteLoading;
begin
  Waitload(false); {used only to set up interface variables}
  SetActive(true); // ReassignKeyboardHandler(true); 
  //DefineDocEvents;    //elh
end;


procedure THtmlObj.DefineDocEvents;
//NOTE: When this function is called, keyboard strokes fire this event, but then
//      the characters never show up in the editor window as having been typed.
begin
 // if DocEvents<>nil then Events.Free;
 // DocEvents := TMSHTMLHTMLDocumentEvents.Create(Self);
 // DocEvents.Connect(IUnknown(Document));
 // DocEvents.OnFocusOut:=OnDocFocusOut;
end;      

procedure THtmlObj.DefineWinEvents;
//NOTE: When this function is called, keyboard strokes fire this event, but then
//      the characters never show up in the editor window as having been typed.
begin
  //if DocEvents<>nil then Events.Free;
  //WinEvents := TMSHTMLHTMLWindowEvents2.Create(Self);
  //DocEvents.Connect(IUnknown(Document));
  //DocEvents.OnFocusOut:=OnDocFocusOut;
end;

procedure THtmlObj.OnDocFocusOut(Sender:TObject);
begin
  messagedlg('This is the new one', mtWarning,mbOKCancel,0);
end;



procedure THtmlObj.ReassignKeyboardHandler(TurnOn : boolean);
{assign HTML keyboard handler to HTML component; restore standard if TurnOn=false}
begin
  if TurnOn then begin
    FApplication.OnMessage := LocalMessageHandler; 
    FCustKeyboardHandlerOn := true;
  end else begin
    FApplication.OnMessage := FOrigAppOnMessage;
    FCustKeyboardHandlerOn := false;
  end;      
end;


procedure THtmlObj.LocalMessageHandler(var Msg: TMsg; var Handled: Boolean);
var 
  Cursor : TPoint;
  i : Integer;

begin
  Handled:=false; //default to not handled  
  exit;
  if not FCustKeyboardHandlerOn then exit;
  if not ((Msg.Message=WM_KEYDOWN) or
          (Msg.Message=WM_KEYUP) or
          (Msg.Message=WM_RBUTTONUP) ) then exit;  //Speedy exit of non-handled messages
  case Msg.Message of
    WM_RBUTTONUP : begin
                     Cursor := ScreenToClient(Msg.pt);
                      //Ignore message if mouse not over this HTML control
                     if (Cursor.X<0) or (Cursor.X>Width) or 
                         (Cursor.Y<0) or (Cursor.Y>Height) then exit;
                     if CtrlToBeProcessed then begin
                       CtrlToBeProcessed := false;                   
                       exit; //Ctrl-right click is ignored
                     end;  
                     if assigned(PopupMenu) then PopupMenu.Popup(Mouse.CursorPos.X,Mouse.CursorPos.Y);
                     Handled:=true;
                     exit;
                   end;
    WM_KEYDOWN :   begin
                     case Msg.WParam of
                       VK_CONTROL : begin
                                      CtrlToBeProcessed:=true;
                                      Handled:=true;                                      
                                      exit;
                                    end;
                       VK_SHIFT :   begin
                                      ShiftToBeProcessed:=true;
                                      Handled:=true;
                                      exit;
                                    end;
                       VK_TAB :     begin
                                      //kt if not FEditable then exit;
                                      if ShiftToBeProcessed then begin
                                        for i := 0 to 5 do begin
                                          PostMessage(Msg.hwnd, WM_KEYDOWN, VK_LEFT, 0);
                                        end;  
                                      end else begin
                                        for i := 0 to 5 do begin
                                          PostMessage(Msg.hwnd, WM_KEYDOWN, VK_SPACE, 0);
                                        end;  
                                      end;  
                                      Handled:=true;
                                    end;
                       VK_RETURN :  if CtrlReturnToBeProcessed then begin 
                                      Handled:=false;                                      
                                      CtrlReturnToBeProcessed := false;
                                    end else if CtrlToBeProcessed then begin
                                      Handled:=true;
                                      CtrlToBeProcessed := False; 
                                      CtrlReturnToBeProcessed := true;
                                      //PostMessage(Msg.hwnd, WM_KEYUP, VK_CONTROL, 0);                                      
                                    end else if ShiftToBeProcessed=false then begin
                                      //kt if not FEditable then exit;
                                      keybd_event(VK_SHIFT,0,0,0);
                                      keybd_event(VK_RETURN,0,0,0);
                                      keybd_event(VK_SHIFT,0,KEYEVENTF_KEYUP,0);
                                      Handled:=true;
                                    end;
                       Ord('B') :  if CtrlToBeProcessed then begin
                                     //kt if not FEditable then exit;
                                     ToggleBold;
                                     Handled:=true;
                                     exit;
                                   end;  
                       Ord('U') :  if CtrlToBeProcessed then begin
                                     //kt if not FEditable then exit;
                                     ToggleUnderline;
                                     Handled:=true;
                                     exit;
                                   end;  
                       Ord('I') :  if CtrlToBeProcessed then begin
                                     //kt if not FEditable then exit;
                                     ToggleItalic;
                                     Handled:=true;
                                   end;  
                     end; {case}
                   end;
    WM_KEYUP :     begin
                     case Msg.WParam of
                       VK_CONTROL : begin
                                      CtrlToBeProcessed:=false;
                                      Handled:=true;
                                      if CtrlReturnToBeProcessed then begin
                                        PostMessage(Msg.hwnd, WM_KEYDOWN, VK_RETURN, 0);
                                      end;                                      
                                      exit;
                                    end;
                       VK_SHIFT :   begin
                                      ShiftToBeProcessed:=false;
                                      Handled:=true;
                                      exit;
                                   end;
                                   
                     end; {case}
                     //messagedlg('I''m Am Not Active', mtWarning,mbOKCancel,0);
                     exit;
                     
                   end;    
  end;  {case}
  end;

procedure THtmlObj.SetHTMLText(Html : String); 
//After this command, Copy and Paste will not work -- ?? why?  Still true??
var V : OleVariant;
    V2 : variant;
    body : IHTMLElement;
    status : string;
    temp : string;
begin
  try
    Stop;
    TheDoc:=Document as IHTMLDocument2;
    if TheDoc=nil then exit;
    body := TheDoc.body;

    if UpperCase(TheDoc.designMode) <> 'ON' then begin
      TheDoc.designMode := 'on';
      repeat  //NOTE: potential endless loop.  Perhaps loop only status='loading'?
        status := TheDoc.readyState;
        {Possible status values:
          uninitialized -- Object is not initialized with data.
          loading             -- Object is loading its data.
          loaded              -- Object has finished loading its data.
          interactive     -- User can interact with the object even though it is not fully loaded.
          complete          -- Object is completely initialized.                                      }      
        if status <> 'complete' then FApplication.ProcessMessages;
      until (status = 'complete') or (status='interactive') or (status='loaded');
    end;  
    body := TheDoc.body;
    if (body = nil) then begin   //Do so stuff to get IE to make a 'body'.
      V2 := VarArrayCreate([0, 0], VarVariant);
      V2[0] := ' ';  //Html;
      TheDoc.Write(PSafeArray(System.TVarData(V2).VArray));
      body := TheDoc.body;
      TheDoc.close;    
      repeat  
        status := TheDoc.readyState; //For possible status values, see above) 
        if status <> 'complete' then FApplication.ProcessMessages;
      until (status = 'complete') or (status='interactive') or (status='loaded');
      body := TheDoc.body;
    end;  
    body.innerHTML := Html;
    temp := body.innerHTML;  //to test if it was set or not...
    Modified:=true;
  except
    on E:Exception do EError('Error setting HTML text',E);
  end;
end;
  
(*
procedure THtmlObj.SetHTMLText(Html : String); 
//After this command, Copy and Paste will not work -- ?? why?  Still true??
var V : OleVariant;
    V2 : variant;
    status : string;
begin
  try
    if (TheDoc=nil) or (TheDoc.body=nil) then begin
      Stop;
      V := Document;// as IHTMLDocument2;
      V.Open;
      V.Clear;
      V.Write(Html);
      V.Close;
      //Fix: Need a way to set font and size in this operation...
    end else begin
      TheDoc.body.innerHTML := Html;
    end;  
    Modified:=true;
  except
    on E:Exception do EError('Error setting HTML text',E);
  end;
end;
*)

function THtmlObj.GetHTMLText:string;
var WS:WideString;
    ch:WideChar;
    n:integer;
    w:word;
    s:string;
begin
  Result:='';
  if TheDoc=nil then exit;
  WS:=TheDoc.body.innerHTML;
  for n:=1 to length(WS) do begin
    ch:=WS[n];
    w:=word(ch);
    if w>255 then begin
       s:=IntToStr(w);
       s:='&#'+s+';';
    end else s:=ch;
    Result:=Result+s;
  end;
end;

function THtmlObj.GetText:string;
var WS:WideString;
    ch:WideChar;
    n:integer;
    w:word;
    s:string;
begin
  Result:='';
  if TheDoc=nil then exit;
  WS:=TheDoc.body.innerText;
  for n:=1 to length(WS) do begin
    ch:=WS[n];
    w:=word(ch);
    if w>255 then begin
      w:=(w mod 256)+48;
      s:=IntToStr(w);
      s:=char(w);
    end else s:=ch;
    Result:=Result+s;
  end;
end;

procedure THtmlObj.SetText(HTML:string);
begin
  if (TheDoc=nil)or(TheDoc.body=nil) then SetHTMLText(HTML)
  else TheDoc.body.innerHTML:=HTML;
end;

function THtmlObj.GetTextLen : integer;
begin
  Result := Length(GetText);
end;    

procedure THtmlObj.Clear;
begin
  SetHTMLText('');
  SetDefaultFont;
end;

function THtmlObj.SelStart:integer;
var TextRange:IHtmlTxtRange;
begin
  Result:=0;
  TextRange:=GetTextRange;
  if TextRange=nil then exit;
  Result:=Abs(Integer(TextRange.move('character',-MaxTextLength)));
end;

function THtmlObj.SelEnd:integer;
var TextRange:IHtmlTxtRange;
begin
  Result:=0;
  TextRange:=GetTextRange;
  if TextRange=nil then exit;
  Result:=Abs(Integer(TextRange.MoveEnd('character',-MaxTextLength)));
end;

function THtmlObj.SelLength:integer;
begin
  Result:=SelEnd-SelStart;
end;

function THtmlObj.GetTextRange:IHtmlTxtRange;
begin
  Result:=nil;
  try
    if TheDoc=nil then exit;
    while TheDoc.body=nil do begin
      WaitLoad(true);
      if TheDoc.body=nil then begin
        if MessageDlg('Wait for document loading?',mtConfirmation,
                      [mbOK,mbCancel],0) <> mrOK then begin
          exit;
        end;  
      end;  
    end;
    if (TheDoc.Selection.type_='Text') or (TheDoc.Selection.type_='None') then begin
      Result:=TheDoc.Selection.CreateRange as IHtmlTxtRange;
    end;  
  except
    on E:Exception do EError('This type of selection cannot be processed',E);
  end;
end;

procedure THtmlObj.SetSelection(Start,Length:integer);
var TextRange:IHtmlTxtRange;
    l : integer ; //kt
begin
  try
     if TheDoc=nil then exit;
     TheDoc.Selection.Empty;
     TextRange:=GetTextRange;
     if TextRange=nil then exit;
     TextRange.collapse(true);
     l:=TextRange.moveEnd('character',Start+Length);
     l:=TextRange.moveStart('character',Start);
     TextRange.select;
  except
    on E:Exception do EError('Error setting HTML selection'+nl+
                             'Start='+IntToStr(Start)+nl+
                             'Length='+IntToStr(Length),E);
    end;
end;


procedure THtmlObj.ClearSelection;
begin
  if TheDoc=nil then exit;
  TheDoc.Selection.Clear;
  Modified:=true;
end;


procedure THtmlObj.ReplaceSelection(HTML:string);
var TextRange:IHtmlTxtRange;
begin
  try
    TextRange:=GetTextRange;
    if TextRange=nil then exit;
    TextRange.PasteHTML(HTML); 
    Modified:=true;
  except
    on E:Exception do begin
      // implement later... ShortenString(HTML,80);
      EError('Error pasting HTML'+nl+
             'Microsoft HTML refuses to paste this string:'+nl+
             HTML+nl,E);
    end;
  end;
end;


function THtmlObj.GetSelText:string;
var TextRange:IHtmlTxtRange;
begin
  Result:='';
  TextRange:=GetTextRange;
  if TextRange=nil then
     exit;
  Result:=TextRange.text;
end;

procedure THtmlObj.SetSelText (HTMLText : string);
begin
  ReplaceSelection(HTMLText);
end;


function THtmlObj.ColorToMSHTMLStr(color : TColor) : string; 
//Note: TColor stores colors lo-byte --> hi-byte as RGB
//Function returns '#RRGGBB'
var tempColor : TMGColor;        
begin
  tempColor.Color := color;
  Result := '#'+
            IntToHex(tempColor.RGBColor.R,2)+  
            IntToHex(tempColor.RGBColor.G,2)+
            IntToHex(tempColor.RGBColor.B,2);
end;

function THtmlObj.MSHTMLStrToColor(MSHTMLColor : string) : TColor;
//Function converts '#RRGGBB' -- TColor
//Note: TColor stores colors lo-byte --> hi-byte as RGB
var tempColor : TMGColor;            
    strHexRed,strHexGreen,strHexBlue : string[2];
begin
  Result := clBlack;  //FIX!!!! IMPLEMENT LATER...
  if Pos('#',MSHTMLColor)=1 then begin
   // MSHTMLColor := MidStr(MSHTMLColor,2,99);
   strHexRed := MidStr(MSHTMLColor,2,2);
   strHexGreen := MidStr(MSHTMLColor,4,2);
   strHexBlue := MidStr(MSHTMLColor,6,2);
   tempColor.RGBColor.R := StrToIntDef('$'+StrHexRed,0);
   tempColor.RGBColor.G := StrToIntDef('$'+StrHexGreen,0);
   tempColor.RGBColor.B := StrToIntDef('$'+StrHexBlue,0);
   Result := tempColor.Color;
   //NOTE: This function has not yet been tested....
  end;
end;

(*
procedure THtmlObj.SetBorder(Border:boolean);
begin
  if TheDoc=nil then exit;
  if TheDoc.body=nil then exit;
  if not Border then begin
     if not FEditable then begin
        TheDoc.body.style.backgroundColor := clYellow; //kt
        TheDoc.body.style.borderStyle:='none';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='white';
        end;
     if FEditable then begin
        TheDoc.body.style.backgroundColor := clRed; //kt
        TheDoc.body.style.borderStyle:='none';
//        TheDoc.body.filters.
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='blue';
        end;
     end;
  if Border then begin
     if not FEditable then begin
        TheDoc.body.style.borderStyle:='solid';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='silver';
        end;
     if FEditable then begin
        //TheDoc.body.style.backgroundColor := ColorToStr(clLime);
        TheDoc.body.style.backgroundColor := 'BtnFace';
        TheDoc.body.style.borderStyle:='solid';
        TheDoc.body.style.borderWidth:='thin';
        TheDoc.body.style.borderColor:='green';
        end;
     end;
end;


*)

initialization

finalization

end.