unit MSHTMLDemoFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdActns, ActnList, ActnMenus, ToolWin, ActnMan, ActnCtrls,
  ExtCtrls, OleCtrls, SHDocVw, ActiveX, MSHTML_TLB, StdCtrls, ImgList,
  ComCtrls, XPStyleActnCtrls, RXSpin, RxCombos, JvExControls, JvComponent,
  JvButton, JvTransparentButton;

type
  TMSHTMLEvent = procedure(Sender: TObject; Event: IHTMLEventObj) of object;

  TMSHTMLEventConnector = class(TInterfacedObject, IDispatch)
  private
    FOnEvent: TMSHTMLEvent;
  private
    // *** Construction and Destruction ***
    constructor Create(Handler: TMSHTMLEvent);
    // *** Implementation of IDispatch interface ***
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    property OnEvent: TMSHTMLEvent read FOnEvent write FOnEvent;
  end;


  TForm1 = class(TForm, IHTMLEditDesigner)
    WebBrowser1: TWebBrowser;
    ActionManager1: TActionManager;
    ControlBar1: TControlBar;
    ActionToolBar2: TActionToolBar;
    ActionMainMenuBar2: TActionMainMenuBar;
    FileOpen: TFileOpen;
    FileSaveAs: TFileSaveAs;
    FileExit1: TFileExit;
    ImageList1: TImageList;
    InsertImageAction: TAction;
    InsertHyperlinkAction: TAction;
    FormatBoldAction: TAction;
    FormatItalicAction: TAction;
    FormatUnderlineAction: TAction;
    Panel1: TPanel;
    TextSizeCombo: TComboBox;
    TextColorCombo: TColorBox;
    Panel2: TPanel;
    JustifyCombo: TComboBox;
    EditCut2: TEditCut;
    EditCopy2: TEditCopy;
    EditPaste2: TEditPaste;
    EditSelectAll2: TEditSelectAll;
    EditUndo2: TEditUndo;
    EditDelete2: TEditDelete;
    EditDocument: TAction;
    StatusBar1: TStatusBar;
    FileNew: TAction;
    Panel3: TPanel;
    SaveButton: TJvTransparentButton;
    CutBtn: TJvTransparentButton;
    CopyBtn: TJvTransparentButton;
    PasteBtn: TJvTransparentButton;
    UndoBtn: TJvTransparentButton;
    BoldBtn: TJvTransparentButton;
    ItalicBtn: TJvTransparentButton;
    UnderlineBtn: TJvTransparentButton;
    LeftBtn: TJvTransparentButton;
    CenterBtn: TJvTransparentButton;
    RightBtn: TJvTransparentButton;
    InsertHyperlinkBtn: TJvTransparentButton;
    InsertImageBtn: TJvTransparentButton;
    Shape1: TShape;
    Label1: TLabel;
    FontSize: TRxSpinEdit;
    SpecialFormatting: TComboBox;
    BlockFormatCombo: TComboBox;
    TextFontCombo: TComboBox;
    RedoBtn: TJvTransparentButton;
    ColorBtn: TJvTransparentButton;
    BackColorBtn: TJvTransparentButton;
    ColorDialog: TColorDialog;
    HorizLineBtn: TJvTransparentButton;
    procedure FileOpenAccept(Sender: TObject);
    procedure InsertImageActionExecute(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormatBoldActionExecute(Sender: TObject);
    procedure FormatBoldActionUpdate(Sender: TObject);
    procedure InsertHyperlinkActionExecute(Sender: TObject);
    procedure InsertHyperlinkActionUpdate(Sender: TObject);
    procedure TextSizeComboChange(Sender: TObject);
    procedure FormatItalicActionExecute(Sender: TObject);
    procedure FormatUnderlineActionExecute(Sender: TObject);
    procedure TextFontComboChange(Sender: TObject);
    procedure TextColorComboChange(Sender: TObject);
    procedure BlockFormatComboChange(Sender: TObject);
    procedure JustifyComboChange(Sender: TObject);
    procedure FileSaveAsAccept(Sender: TObject);
    procedure EditDocumentExecute(Sender: TObject);
    procedure FileNewExecute(Sender: TObject);
    procedure WebBrowser1NavigateComplete2(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure SaveButtonClick(Sender: TObject);
    procedure FontSizeBottomClick(Sender: TObject);
    procedure LeftBtnClick(Sender: TObject);
    procedure CenterBtnClick(Sender: TObject);
    procedure RightBtnClick(Sender: TObject);
    procedure BoldBtnClick(Sender: TObject);
    procedure ItalicBtnClick(Sender: TObject);
    procedure UnderlineBtnClick(Sender: TObject);
    procedure InsertImageBtnClick(Sender: TObject);
    procedure InsertHyperlinkBtnClick(Sender: TObject);
    procedure CutBtnClick(Sender: TObject);
    procedure CopyBtnClick(Sender: TObject);
    procedure PasteBtnClick(Sender: TObject);
    procedure UndoBtnClick(Sender: TObject);
    procedure RedoBtnClick(Sender: TObject);
    procedure BackColorBtnClick(Sender: TObject);
    procedure ColorBtnClick(Sender: TObject);
    procedure SpecialFormattingChange(Sender: TObject);
    procedure HorizLineBtnClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

  private
    FDblClickConnector: TMSHTMLEventConnector;
    FClickConnector: TMSHTMLEventConnector;
    FKeyPressConnector: TMSHTMLEventConnector;
    function GetHTMLDocument2Ifc: IHTMLDocument2;

    procedure UpdateAll;

    // *** Scripting events ***
    procedure WebEditorDblClk(Sender: TObject; EventObjIfc: IHTMLEventObj);
    procedure WebEditorClick(Sender: TObject; EventObjIfc: IHTMLEventObj);
    procedure WebEditorKeyPress(Sender: TObject; EventObjIfc: IHTMLEventObj);

    // *** Implementation of IHTMLHost
    function SnapRect(const pIElement: IHTMLElement; var prcNew: tagRECT; eHandle: _ELEMENT_CORNER): HResult; stdcall;

    // *** Implementation of IHTMLEditDesigner ***
    function PreHandleEvent(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult; stdcall;
    function PostHandleEvent(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult; stdcall;
    function TranslateAccelerator(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult; stdcall;
    function PostEditorEventNotify(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult; stdcall;

  protected
    property HTMLDocument2Ifc: IHTMLDocument2 read GetHTMLDocument2Ifc;
    procedure AfterLoad;
    procedure BeforeLoad;

  public
    { Public declarations }
    Modified: Boolean;
    procedure FocusEditor;
  end;

var
  Form1: TForm1;

implementation

uses ComObj, DocumentPropertiesDlg, Main;

{$R *.dfm}

const
  // Service ID (GUID) for the HTML Edit Services
  SID_SHTMLEditServices: TGUID = (D1: $3050f7f9; D2: $98b5; D3: $11cf; D4: ($bb, $82, $00, $AA, $00, $bd, $ce, $0b));

function RGBToBGR(RGB: TColor): Integer;
begin
  Result := (RGB and $000000ff) shl 16 + (RGB and $0000ff00) + (RGB and $00ff0000) shr 16;
end;


function ColorStr(RGB: TColor): string;
begin
  Result := '#' + IntToHex(RGBToBGR(RGB), 6);
end;


procedure TForm1.FileOpenAccept(Sender: TObject);
var
  FileName: WideString;
begin
  FileName := FileOpen.Dialog.FileName;
  (HTMLDocument2Ifc as IPersistFile).Load(PWideChar(FileName), 0);
end;


function TForm1.GetHTMLDocument2Ifc: IHTMLDocument2;
begin
  Result := WebBrowser1.Document as IHTMLDocument2;
end;


procedure TForm1.InsertImageActionExecute(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('InsertImage', True, 0);
end;


procedure TForm1.FormCreate(Sender: TObject);
var
  FileName: WideString;
begin
  Modified := False;
  
  FDblClickConnector := TMSHTMLEventConnector.Create(WebEditorDblClk);
  FClickConnector := TMSHTMLEventConnector.Create(WebEditorClick);
  FKeyPressConnector := TMSHTMLEventConnector.Create(WebEditorKeyPress);
  WebBrowser1.Navigate(MainForm.OpenDialog.FileName);
  AfterLoad;

{  if FileExists(MainForm.OpenDialog.FileName) then
   (HTMLDocument2Ifc as IPersistFile).Load(PWideChar(MainForm.OpenDialog.FileName), 0);}
end;


procedure TForm1.FormatBoldActionExecute(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Bold', False, 0);
  FocusEditor;
end;


procedure TForm1.FormatBoldActionUpdate(Sender: TObject);
begin
  FormatBoldAction.Checked := HTMLDocument2Ifc.queryCommandValue('Bold');
end;


procedure TForm1.InsertHyperlinkActionExecute(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('CreateLink', True, 0);
  FocusEditor;
end;


procedure TForm1.InsertHyperlinkActionUpdate(Sender: TObject);
begin
  InsertHyperlinkAction.Enabled := HTMLDocument2Ifc.queryCommandEnabled('CreateLink');
end;


procedure TForm1.TextSizeComboChange(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('FontSize', False, TextSizeCombo.Items[TextSizeCombo.ItemIndex]);
end;


procedure TForm1.FormatItalicActionExecute(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Italic', False, 0);
end;


procedure TForm1.FormatUnderlineActionExecute(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Underline', False, 0);
end;


procedure TForm1.TextFontComboChange(Sender: TObject);
begin
  if TextFontCombo.ItemIndex = 0 then
    HTMLDocument2Ifc.execCommand('FontName', True, '')
  else
    HTMLDocument2Ifc.execCommand('FontName', True, TextFontCombo.Items[TextFontCombo.ItemIndex]);
end;


procedure TForm1.TextColorComboChange(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('ForeColor', False, ColorStr(TextColorCombo.Selected));
end;


procedure TForm1.BlockFormatComboChange(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('FormatBlock', True, BlockFormatCombo.Text);
end;


procedure TForm1.JustifyComboChange(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Justify' + JustifyCombo.Text, False, 0);
end;


procedure TForm1.FileSaveAsAccept(Sender: TObject);
var
  FileName: WideString;
begin
  FileName := FileSaveAs.Dialog.FileName;
  (HTMLDocument2Ifc as IPersistFile).Save(PWideChar(FileName), True);
end;


procedure TForm1.EditDocumentExecute(Sender: TObject);
begin
  if DocumentPropertiesDialog.ShowModal = mrOk then begin
    if DocumentPropertiesDialog.BgImageEdit.Text = '' then
      (HTMLDocument2Ifc.body as IHTMLBodyElement).bgColor := ColorStr(DocumentPropertiesDialog.BgColorCombo.Selected)
    else
      (HTMLDocument2Ifc.body as IHTMLBodyElement).background := DocumentPropertiesDialog.BgImageEdit.Text;
  end;
end;


{ TMSHTMLEventConnector }

constructor TMSHTMLEventConnector.Create(Handler: TMSHTMLEvent);
begin
  inherited Create;
  _AddRef;
  FOnEvent := Handler;
end;


function TMSHTMLEventConnector.GetIDsOfNames(const IID: TGUID;
  Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;


function TMSHTMLEventConnector.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
end;


function TMSHTMLEventConnector.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
end;


function TMSHTMLEventConnector.Invoke(DispID: Integer;
  const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult,
  ExcepInfo, ArgErr: Pointer): HResult;
var
  HTMLEventObjIfc: IHTMLEventObj;
begin
  Result := S_OK;
  if Assigned(FOnEvent) then FOnEvent(Self, HTMLEventObjIfc);
end;


procedure TForm1.WebEditorClick(Sender: TObject; EventObjIfc: IHTMLEventObj);
begin
  // ShowMessage('Click');
  // HTMLDocument2Ifc.parentWindow.event.cancelBubble := True;
  UpdateAll;
end;

procedure TForm1.WebEditorKeyPress(Sender: TObject; EventObjIfc: IHTMLEventObj);
begin
  UpdateAll;
end;

procedure TForm1.WebEditorDblClk(Sender: TObject; EventObjIfc: IHTMLEventObj);
var
  HTMLImageIfc: IHTMLImgElement;
  Width, Height: Integer;
begin
{  if Supports(HTMLDocument2Ifc.parentWindow.event.srcElement, IHTMLImgElement, HTMLImageIfc) then
    ShowMessage('It''s an image.');}
end;


function TForm1.SnapRect(const pIElement: IHTMLElement;
  var prcNew: tagRECT; eHandle: _ELEMENT_CORNER): HResult;
begin
  prcNew.left := 20 * (prcNew.left div 20);
  prcNew.top := 20 * (prcNew.top div 20);
  prcNew.right := 20 * (prcNew.right div 20);
  prcNew.bottom := 20 * (prcNew.bottom div 20);
  Result := S_OK;
end;


function TForm1.PostEditorEventNotify(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult;
begin
  if inEvtDispId = -606 then begin
    // onmousemove
    StatusBar1.Panels[0].Text := IntToStr(pIEventObj.clientX) + ':' + IntToStr(pIEventObj.clientY);
  end;
  Result := S_FALSE;
end;


function TForm1.PostHandleEvent(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult;
begin
  Result := S_FALSE;
end;


function TForm1.PreHandleEvent(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult;
begin
  Result := S_FALSE;
end;


function TForm1.TranslateAccelerator(inEvtDispId: Integer; const pIEventObj: IHTMLEventObj): HResult;
begin
  Result := S_FALSE;
end;


procedure TForm1.FileNewExecute(Sender: TObject);
begin
  WebBrowser1.Navigate('about:blank');
end;


procedure TForm1.AfterLoad;
var
  HTMLEditServicesIfc: IHTMLEditServices;
begin
  // Set document to design mode
  HTMLDocument2Ifc.designMode := 'On';
  // Register scripting event handlers
  HTMLDocument2Ifc.ondblclick := FDblClickConnector as IDispatch;
  HTMLDocument2Ifc.onclick := FClickConnector as IDispatch;
  HTMLDocument2Ifc.onkeypress := FKeyPressConnector as IDispatch;
  // Register edit designer
  (HTMLDocument2Ifc as IServiceProvider).QueryService(SID_SHTMLEditServices, IHTMLEditServices, HTMLEditServicesIfc);
  HTMLEditServicesIfc.AddDesigner(Self);
end;


procedure TForm1.BeforeLoad;
var
  HTMLEditServicesIfc: IHTMLEditServices;
begin
  (HTMLDocument2Ifc as IServiceProvider).QueryService(SID_SHTMLEditServices, IHTMLEditServices, HTMLEditServicesIfc);
  HTMLEditServicesIfc.RemoveDesigner(Self);
  HTMLDocument2Ifc.ondblclick := Null;
  HTMLDocument2Ifc.onclick := Null;
  HTMLDocument2Ifc.onkeypress := Null;
end;


procedure TForm1.WebBrowser1NavigateComplete2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  AfterLoad;
end;

procedure TForm1.SaveButtonClick(Sender: TObject);
var
  FileName: WideString;
begin
  FileName := MainForm.OpenDialog.FileName;
  (HTMLDocument2Ifc as IPersistFile).Save(PWideChar(FileName), True);
  Modified := False;
  Close;
end;

procedure TForm1.FontSizeBottomClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('FontSize', False, FontSize.Value);
  FocusEditor;
end;

procedure TForm1.LeftBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('JustifyLeft', False, 0);
  FocusEditor;
end;

procedure TForm1.CenterBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('JustifyCenter', False, 0);
  FocusEditor;
end;

procedure TForm1.RightBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('JustifyRight', False, 0);
  FocusEditor;
end;

procedure TForm1.BoldBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Bold', False, 0);
  FocusEditor;
end;

procedure TForm1.ItalicBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Italic', False, 0);
  FocusEditor;
end;

procedure TForm1.UnderlineBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Underline', False, 0);
  FocusEditor;
end;

procedure TForm1.InsertImageBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('InsertImage', True, 0);
  FocusEditor;
end;

procedure TForm1.InsertHyperlinkBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('CreateLink', True, 0);
  FocusEditor;
end;

procedure TForm1.FocusEditor;
begin
  WebBrowser1.SetFocus;
end;

procedure TForm1.CutBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Cut', False, 0);
  FocusEditor;
end;

procedure TForm1.CopyBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Copy', False, 0);
  FocusEditor;
end;

procedure TForm1.PasteBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Paste', False, 0);
  FocusEditor;
end;

procedure TForm1.UndoBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Undo', False, 0);
  FocusEditor;
end;

procedure TForm1.RedoBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('Redo', False, 0);
  FocusEditor;
end;

procedure TForm1.BackColorBtnClick(Sender: TObject);
begin
  if ColorDialog.Execute then
  begin
    HTMLDocument2Ifc.execCommand('BackColor', True, ColorDialog.Color);
    FocusEditor;
  end;
end;

procedure TForm1.ColorBtnClick(Sender: TObject);
begin
  if ColorDialog.Execute then
  begin
    HTMLDocument2Ifc.execCommand('ForeColor', True, ColorDialog.Color);
    FocusEditor;
  end;
end;

procedure TForm1.SpecialFormattingChange(Sender: TObject);
begin
  case SpecialFormatting.ItemIndex of
   0: // Title
      begin
        HTMLDocument2Ifc.execCommand('FontName', False, 'Tahoma');
        HTMLDocument2Ifc.execCommand('FontSize', False, '4');
        if not HTMLDocument2Ifc.queryCommandValue('Bold') then
         HTMLDocument2Ifc.execCommand('Bold', False, 0);
        if not HTMLDocument2Ifc.queryCommandValue('Italic') then
         HTMLDocument2Ifc.execCommand('Italic', False, 0);
        if HTMLDocument2Ifc.queryCommandValue('Underline') then { Disable underline }
         HTMLDocument2Ifc.execCommand('Italic', False, 0);
        HTMLDocument2Ifc.execCommand('ForeColor', False, $909bb);
      end;
   1: // Headline
      begin
        HTMLDocument2Ifc.execCommand('FontName', False, 'Tahoma');
        HTMLDocument2Ifc.execCommand('FontSize', False, '6');

        if not HTMLDocument2Ifc.queryCommandValue('Bold') then
         HTMLDocument2Ifc.execCommand('Bold', False, 0);
        if HTMLDocument2Ifc.queryCommandValue('Italic') then  { Disable italic }
         HTMLDocument2Ifc.execCommand('Italic', False, 0);
        if HTMLDocument2Ifc.queryCommandValue('Underline') then { Disable underline }
         HTMLDocument2Ifc.execCommand('Italic', False, 0);

        HTMLDocument2Ifc.execCommand('ForeColor', False, $909bb);
      end;
   2: // Ordinary
      begin
        HTMLDocument2Ifc.execCommand('FontName', False, 'Arial');
        HTMLDocument2Ifc.execCommand('FontSize', False, '2');
        HTMLDocument2Ifc.execCommand('ForeColor', False, $2e5c5c);
        if HTMLDocument2Ifc.queryCommandValue('Bold') then { Disable bold }
         HTMLDocument2Ifc.execCommand('Bold', False, 0);
        if HTMLDocument2Ifc.queryCommandValue('Italic') then  { Disable italic }
         HTMLDocument2Ifc.execCommand('Italic', False, 0);
        if HTMLDocument2Ifc.queryCommandValue('Underline') then { Disable underline }
         HTMLDocument2Ifc.execCommand('Italic', False, 0);
      end;
  end;
  SpecialFormatting.ItemIndex := -1;
  FocusEditor;
end;

procedure TForm1.UpdateAll;
begin
  Modified := True;

  { Update all controls }
  try
  BoldBtn.Down := HTMLDocument2Ifc.queryCommandValue('Bold');
  ItalicBtn.Down := HTMLDocument2Ifc.queryCommandValue('Italic');
  UnderlineBtn.Down := HTMLDocument2Ifc.queryCommandValue('Underline');

  LeftBtn.Down := HTMLDocument2Ifc.queryCommandValue('JustifyLeft');
  CenterBtn.Down := HTMLDocument2Ifc.queryCommandValue('JustifyCenter');
  RightBtn.Down := HTMLDocument2Ifc.queryCommandValue('JustifyRight');

  FontSize.Text := HTMLDocument2Ifc.queryCommandValue('FontSize');
  TextFontCombo.Text := HTMLDocument2Ifc.queryCommandValue('FontName');
  BlockFormatCombo.Text := HTMLDocument2Ifc.queryCommandValue('FormatBlock');
  except
  end;
end;

procedure TForm1.HorizLineBtnClick(Sender: TObject);
begin
  HTMLDocument2Ifc.execCommand('InsertHorizontalRule', False, 0);
  FocusEditor;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if Modified then
   if Application.MessageBox('Save changes to your document?', 'Confirm Exit', MB_YESNO+MB_ICONQUESTION) = mrYes then
    SaveButtonClick(Self);
  CanClose := True;
end;

end.
