OmHTMLEditor

{------------------------------------------------------------------------------    }
{                       Delphi's HTMLEditor Component                              }
{                             2013-04-05                                           }
{                                                                                  }
{                                                                                  }
{                                                                                  }
{------------------------------------------------------------------------------    }


unit OmHTMLEditor;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls,
  MSHTML, ExtCtrls, OleCtrls, Dialogs, Graphics,
  SHDocVw, ActiveX, ActnList, Contnrs, DB, DBCtrls,Variants;


{------------------------------------------------------------------------------}
type
  TOmHTMLEditorCommand =
    (
    hecBulletList
    , hecCopy
    , hecPaste
    , hecCut
    , hecRedo
    , hecUndo
    , hecForegroundColor
    , hecSearch
    , hecIdentLeft
    , hecIdentRight
    , hecInsertImage
    , hecCreateLink
    , hecInsertTable
    , hecItalic
    , hecNumberedList
    , hecUnderLine
    , hecAlignLeft
    , hecAlignCenter
    , hecAlignRight
    , hecBold
    , hecBackGroundColor
    );
{------------------------------------------------------------------------------}
const
  HTMLEditorCommands: array[TOmHTMLEditorCommand] of string =
  (
    'insertunorderedlist' //hecBulletList
    , 'Copy' //hecCopy
    , 'Paste' //hecPaste
    , 'Cut' //hecCut
    , 'Redo' //hecRedo
    , 'Undo' //hecUndo
    , 'ForeColor' //hecForegroundColor
    , 'Search' //hecSearch
    , 'Outdent' //hecIdentLeft
    , 'Indent' //hecIdentRight
    , 'InsertImage' //hecInsertImage
    , 'createlink' //hecCreateLink
    , 'tableInsert' //hecInsertTable
    , 'Italic' //hecItalic
    , 'insertorderedlist' //hecNumberedList
    , 'Underline' //hecUnderLine
    , 'JustifyLeft' //hecAlignLeft
    , 'JustifyCenter' //hecAlignCenter
    , 'JustifyRight' //hecAlignRight
    , 'Bold' //hecBold
    , 'BackColor' //hecBackGroundColor
    );

  HTMLID_FIND = 1;
  HTMLID_VIEWSOURCE = 2;
  HTMLID_OPTIONS = 3;
{------------------------------------------------------------------------------}



type
  TOmHTMLEditor = class(TWinControl)
  private
    FHTMLEditor: TWebBrowser;
    FCommandList: TStrings;
    FHTMLText: TStrings;
    FHTMLToolBar: Boolean;
    FIsBold: Boolean;
    FIsItalic: Boolean;
    FIsAlignLeft: Boolean;
    FIsAlignCenter: Boolean;
    FIsAlignRight: Boolean;
    FIsNumberedList: Boolean;
    FIsBulletedList: Boolean;
    FIsUnderLine: Boolean;
    FOnCommandChange: TNotifyEvent;
    function GetHTMLText: TStrings;
    procedure SetHTMLText(const Value: TStrings);
    {-------new method----------------}
    function GetHTML: WideString;
    procedure SetHTML(const Value: WideString);
    function GetText: WideString;
    {-------new method-----------------}
    { private declarations }
  protected
    { protected declarations }
    function HasDocument: Boolean;
    function GetDocument: IHTMLDocument2;
    procedure DoExecuteCommand(ACommand: string; ShowUI: Boolean; Value: OleVariant);
    procedure RegisterDefaultCommands;
    procedure InternalOnActionExecute(Sender: TObject);
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure InternalOnBrowserCommandStateChange(ASender: TObject; Command: Integer; Enable: WordBool);
    procedure DoEdit; virtual;
    procedure DoSave; virtual;
  public
    { public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  public
    procedure LoadFromStream(AStream: TStream);
    procedure SaveToStream(AStream: TStream);
    procedure LoadFromFile(AFileName: string);
    procedure SaveToFile(AFileName: string);
  public
    //Interface Commands
    procedure BulletList;
    procedure Copy;
    procedure Paste;
    procedure Cut;
    procedure Redo;
    procedure Undo;
    procedure SetForegroundColor(AColor: TColor);
    procedure Search;
    procedure IdentLeft;
    procedure IdentRight;
    procedure InsertImage;
    procedure CreateLink;
    procedure InsertTable; overload;
    procedure Italic;
    procedure NumberedList;
    procedure UnderLine;
    procedure AlignLeft;
    procedure AlignCenter;
    procedure AlignRight;
    procedure Bold;
    procedure SetBackGroundColor(AColor: TColor);

    procedure Edit; overload;
    procedure Edit(Text: string; AutoEdit: Boolean = True); overload;
    procedure Save;
    procedure ConnectActionToCommand(EditorCommand: TOmHTMLEditorCommand; ACtion: TAction);
    procedure ConnectClickableControlToCommand(EditorCommand: TOmHTMLEditorCommand; AControl: TControl);
    {----------new method-----------}
    procedure InsertTable(const Col: Integer = 2; const Row: Integer = 2); overload;
    procedure InsertHTML(const html: WideString);
    procedure FontName(const AFontName: string);
    procedure FontSize(const AFontSize: Integer);
    procedure SelectAll;
    procedure Clear;
    function  IsSelected: Boolean;
    procedure LineHeight(const height:Double = 1);
    procedure SaveAs;
    procedure PrintPreview;
    {---------new method------------}
  public
    property HTMLEditor: TWebBrowser read FHTMLEditor;
    property IsBold: Boolean read FIsBold;
    property IsItalic: Boolean read FIsItalic;
    property IsAlignLeft: Boolean read FIsAlignLeft;
    property IsAlignCenter: Boolean read FIsAlignCenter;
    property IsAlignRight: Boolean read FIsAlignRight;
    property IsNumberedList: Boolean read FIsNumberedList;
    property IsBulletedList: Boolean read FIsBulletedList;
    property IsUnderLine: Boolean read FIsUnderLine;
  published
    { published declarations }
    property HTMLText: TStrings read GetHTMLText write SetHTMLText;
    {----------------------}
    property HTML: WideString read GetHTML write SetHTML;
    property Text: WideString read GetText;
     {----------------------}
  published
    property Align;
    property OnCommandChange: TNotifyEvent read FOnCommandChange write FOnCommandChange;
  end;


implementation


uses
  Forms, TypInfo;

{ TddHTMLEditor }
{------------------------------------------------------------------------------}

constructor TOmHTMLEditor.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Self.Height := Self.Height * 2;
  FHTMLEditor := TWebBrowser.Create(Self);
  FHTMLEditor.OnCommandStateChange := InternalOnBrowserCommandStateChange;
  TOleControl(FHTMLEditor).Parent := Self;
  FHTMLEditor.Align := alClient;
  FCommandList := TStringList.Create;
  FHTMLText := TStringList.Create;
  RegisterDefaultCommands;

  FHTMLEditor.Navigate('about:blank');
  OleInitialize(nil);
end;
{------------------------------------------------------------------------------}

destructor TOmHTMLEditor.Destroy;
begin
  FCommandList.Free;
  FCommandList := nil;
  FHTMLText.Free;
  FHTMLText := nil;
  OleUninitialize;
  inherited;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Notification(AComponent: TComponent; Operation: TOperation);
var
  Idx: Integer;
  ACmd: TOmHTMLEditorCommand;
begin

  if Operation = opRemove then
  begin
    if (FCommandList <> nil) then
    begin
      Idx := FCommandList.IndexOfObject(AComponent);
      if Idx >= 0 then
      begin
        ACmd := TOmHTMLEditorCommand(Idx);
        FCommandList.Delete(Idx);
        FCommandList.Insert(Idx, HTMLEditorCommands[ACmd]);
      end;
    end;
  end;

  inherited Notification(AComponent, Operation);

end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.RegisterDefaultCommands;
var
  i: Integer;
begin
  for I := Ord(hecBulletList) to Ord(hecBackGroundColor) do
  begin
    FCommandList.Add(HTMLEditorCommands[TOmHTMLEditorCommand(i)]);
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.DoEdit;
begin
  if HasDocument then
  begin
    GetDocument.designMode := 'On';
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.DoSave;
begin
  if HasDocument then
  begin
    GetDocument.designMode := 'Off';
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.DoExecuteCommand(ACommand: string; ShowUI: Boolean; Value: OleVariant);
begin
  if HasDocument then
  begin
    Self.GetDocument.execCommand(ACommand, ShowUI, Value);
  end;
end;

{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Save;
begin
  DoSave;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Edit;
begin
  DoEdit;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Edit(Text: string; AutoEdit: Boolean);
var
  StrStream: TStringStream;
begin
  StrStream := TStringStream.Create(Text);
  try
    Self.LoadFromStream(StrStream);
    if AutoEdit then
      Self.Edit;
  finally
    StrStream.Free;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.ConnectActionToCommand(EditorCommand: TOmHTMLEditorCommand; ACtion: TAction);
var
  Idx: Integer;
begin
  Idx := FCommandList.IndexOf(HTMLEditorCommands[EditorCommand]);
  if Idx >= 0 then
  begin
    FCommandList.Objects[Idx] := Action;
    Action.FreeNotification(Self);
    Action.OnExecute := InternalOnActionExecute;
  end;
end;
{------------------------------------------------------------------------------}
type
  _TControl = class(TControl);

procedure TOmHTMLEditor.ConnectClickableControlToCommand(EditorCommand: TOmHTMLEditorCommand; AControl: TControl);
var
  Idx: Integer;
begin
  Idx := FCommandList.IndexOf(HTMLEditorCommands[EditorCommand]);
  if Idx >= 0 then
  begin
    if IsPublishedProp(AControl, 'OnClick') then
    begin
      FCommandList.Objects[Idx] := AControl;
      AControl.FreeNotification(Self);
      _TControl(AControl).OnClick := InternalOnActionExecute;
    end;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.SelectAll;
begin
  if (FHTMLEditor.QueryStatusWB(OLECMDID_SELECTALL) = (OLECMDF_ENABLED or OLECMDF_SUPPORTED)) then
    FHTMLEditor.ExecWB(OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Copy;
begin
  //DoExecuteCommand(HTMLEditorCommands[hecCopy], True, 0);
  if (FHTMLEditor.QueryStatusWB(OLECMDID_COPY) = (OLECMDF_ENABLED or OLECMDF_SUPPORTED)) then
    FHTMLEditor.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Paste;
begin
  DoExecuteCommand(HTMLEditorCommands[hecPaste], True, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Redo;
begin
  DoExecuteCommand(HTMLEditorCommands[hecRedo], True, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Cut;
begin
  //DoExecuteCommand(HTMLEditorCommands[hecCut], True, 0);
  if (FHTMLEditor.QueryStatusWB(OLECMDID_CUT) = (OLECMDF_ENABLED or OLECMDF_SUPPORTED)) then
    FHTMLEditor.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.AlignCenter;
begin
  DoExecuteCommand(HTMLEditorCommands[hecAlignCenter], False, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.AlignLeft;
begin
  DoExecuteCommand(HTMLEditorCommands[hecAlignLeft], False, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.AlignRight;
begin
  DoExecuteCommand(HTMLEditorCommands[hecAlignRight], False, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Bold;
begin
  DoExecuteCommand(HTMLEditorCommands[hecBold], False, not FIsBold);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.BulletList;
begin
  DoExecuteCommand(HTMLEditorCommands[hecBulletList], False, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.SetBackGroundColor(AColor: TColor);
begin
  DoExecuteCommand(HTMLEditorCommands[hecBackGroundColor], False, AColor);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.SetForegroundColor(AColor: TColor);
begin
  DoExecuteCommand(HTMLEditorCommands[hecForegroundColor], False, AColor);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.UnderLine;
begin
  DoExecuteCommand(HTMLEditorCommands[hecUnderline], False, not FIsUnderLine);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Undo;
begin
  DoExecuteCommand(HTMLEditorCommands[hecUndo], False, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.IdentLeft;
begin
  DoExecuteCommand(HTMLEditorCommands[hecIdentLeft], True, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.IdentRight;
begin
  DoExecuteCommand(HTMLEditorCommands[hecIdentRight], True, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.InsertImage;
begin
  DoExecuteCommand(HTMLEditorCommands[hecInsertImage], True, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.InsertTable;
begin
  DoExecuteCommand(HTMLEditorCommands[hecInsertTable], False, 0);
end;

procedure TOmHTMLEditor.InsertHTML(const html: WideString);
begin
  if LowerCase(GetDocument.selection.type_) <> 'none' then
    GetDocument.selection.clear;
  (GetDocument.selection.createRange as IHTMLTxtRange).pasteHTML(html);

  SetFocus;
end;

procedure TOmHTMLEditor.InsertTable(const Col: Integer = 2; const Row: Integer = 2);
var
  ColCnt, RowCnt: Integer;
  sTable: string;
begin
  sTable := '';
  for RowCnt := 1 to Row do
  begin
    sTable := sTable + '';
    for ColCnt := 1 to Col do
      sTable := sTable + '';
    sTable := sTable + '';
  end;
  sTable := sTable + '';
  InsertHTML(sTable);
end;

{------------------------------------------------------------------------------}
function TOmHTMLEditor.GetHTML: WideString;
begin
  Result := GetDocument.body.outerHTML;
end;

function TOmHTMLEditor.GetText: WideString;
begin
  Result := GetDocument.body.outerText;
end;

procedure TOmHTMLEditor.SetHTML(const Value: WideString);
var
  Html: Variant;
begin
  Html := VarArrayCreate([0, 0], varVariant);
  Html[0] := Value;
  GetDocument.write(pSafearray(TVarData(Html).VArray));
end;

procedure TOmHTMLEditor.Clear();
var
  Html: Variant;
begin
  Html := VarArrayCreate([0, 0], varVariant);
  Html[0] := '';
  GetDocument.close;
  GetDocument.clear;
  GetDocument.write(pSafearray(TVarData(Html).VArray));
  DoEdit;
end;

function TOmHTMLEditor.IsSelected: Boolean;
begin
  Result := False;
  if LowerCase(GetDocument.selection.type_) <> 'none' then
    Result := True;
end;

procedure TOmHTMLEditor.LineHeight(const height:double);
begin
  //height=1, 1.5, 2 
  GetDocument.body.style.lineHeight := height;
end;

{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Italic;
begin
  DoExecuteCommand(HTMLEditorCommands[hecItalic], False, not FIsItalic);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.CreateLink;
begin
  DoExecuteCommand(HTMLEditorCommands[hecCreateLink], True, 0);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.NumberedList;
begin
  DoExecuteCommand(HTMLEditorCommands[hecNumberedList], True, 0);
end;

procedure TOmHTMLEditor.FontName(const AFontName: string);
begin
  if Trim(AFontName) <> '' then
    DoExecuteCommand('FontName', True, '"' + AFontName + '"');
end;

procedure TOmHTMLEditor.FontSize(const AFontSize: Integer);
begin
  case AFontSize of
    1..7: DoExecuteCommand('FontSize', True, AFontSize);
  else
    DoExecuteCommand('FontSize', True, 3);
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.Search;
const
  CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
  CmdTarget: IOleCommandTarget;
  vaIn, vaOut: OleVariant;
  PtrGUID: PGUID;
begin
  if HasDocument then
  begin
    New(PtrGUID);
    PtrGUID^ := CGID_WebBrowser;
    try
      GetDocument.QueryInterface(IOleCommandTarget, CmdTarget);
      if CmdTarget <> nil then
      try
        CmdTarget.Exec(PtrGUID, HTMLID_FIND, 0, vaIn, vaOut);
      finally
        CmdTarget._Release;
      end;
    except
    end;
    Dispose(PtrGUID);
  end;
end;
{------------------------------------------------------------------------------}

function TOmHTMLEditor.GetDocument: IHTMLDocument2;
begin
  Result := nil;
  if HasDocument then
    Result := (FHTMLEditor.Document as IHTMLDocument2);
end;
{------------------------------------------------------------------------------}

function TOmHTMLEditor.HasDocument: Boolean;
begin
  Result := Assigned(FHTMLEditor.Document);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.LoadFromFile(AFileName: string);
var
  Fs: TFileStream;
begin
  if FileExists(AFileName) then
  begin
    Fs := TFileStream.Create(AFileName, fmOpenRead);
    try
      Self.LoadFromStream(Fs);
    finally
      Fs.Free;
    end;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.LoadFromStream(AStream: TStream);
begin
  if (Assigned(AStream)) then
  begin
    FHTMLEditor.Navigate('about:blank');
    if HasDocument then
    begin
      AStream.Seek(0, soFromBeginning);
      while FHTMLEditor.ReadyState < READYSTATE_INTERACTIVE do
        Application.ProcessMessages;
      (FHTMLEditor.Document as IPersistStreamInit).Load(TStreamAdapter.Create(aStream));
    end;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.SaveAs;
begin
    FHTMLEditor.ExecWB(OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT);
end;

procedure TOmHTMLEditor.PrintPreview;
begin
  FHTMLEditor.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT);
end;

procedure TOmHTMLEditor.SaveToFile(AFileName: string);
var
  Fs: TFileStream;
begin
  Fs := TFileStream.Create(AFileName, fmCreate);
  try
    Self.SaveToStream(Fs);
  finally
    Fs.Free;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.SaveToStream(AStream: TStream);
begin
  if (Assigned(AStream)) then
  begin
    if HasDocument then
    begin
      AStream.Seek(0, soFromBeginning);
      (FHTMLEditor.Document as IPersistStreamInit).Save(TStreamAdapter.Create(aStream), True);
    end;
  end;
end;
{------------------------------------------------------------------------------}

function TOmHTMLEditor.GetHTMLText: TStrings;
var
  BodyElement: IHTMLElement;
  Doc: IHTMLDocument2;
begin
  FHTMLText.Clear;
  Result := FHTMLText;
  if HasDocument then
  begin
    Doc := GetDocument;
    if Doc.QueryInterface(IHTMLDocument2, Doc) = S_OK then
    begin
      BodyElement := Doc.body;
      if Assigned(BodyElement) then
      begin
        FHTMLText.Text := BodyElement.innerHTML;
        Result := FHTMLText;
      end;
    end;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.SetHTMLText(const Value: TStrings);
begin
  if Assigned(Value) then
    Edit(Value.Text, False);
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.InternalOnActionExecute(Sender: TObject);
var
  ACmd: TOmHTMLEditorCommand;
  Idx: Integer;
  ClrDlg: TColorDialog;
begin
  Idx := FCommandList.IndexOfObject(Sender);
  if Idx >= 0 then
  begin
    ACmd := TOmHTMLEditorCommand(Idx);
    case ACmd of
      hecBulletList: Self.BulletList;
      hecCopy: Self.Copy;
      hecPaste: Self.Paste;
      hecCut: Self.Cut;
      hecRedo: Self.Redo;
      hecUndo: Self.Undo;
      hecForegroundColor, hecBackGroundColor:
        begin
          ClrDlg := TColorDialog.Create(nil);
          try
            ClrDlg.Options := [cdFullOpen, cdAnyColor];
            if ClrDlg.Execute then
            begin
              Self.DoExecuteCommand(HTMLEditorCommands[Acmd], False, ClrDlg.Color);
              // Self.SetForegroundColor(ClrDlg.Color);
            end;
          finally
            FreeAndNil(ClrDlg);
          end;
        end;
      hecSearch: Self.Search;
      hecIdentLeft: Self.IdentLeft;
      hecIdentRight: Self.IdentRight;
      hecInsertImage: Self.InsertImage;
      hecCreateLink: Self.CreateLink;
      hecInsertTable: Self.InsertTable(2, 2);
      hecItalic: Self.Italic;
      hecBold: Self.Bold;
      hecNumberedList: Self.NumberedList;
      hecUnderLine: Self.UnderLine;
      hecAlignLeft: Self.AlignLeft;
      hecAlignCenter: Self.AlignCenter;
      hecAlignRight: Self.AlignRight;
    end;
  end;
end;
{------------------------------------------------------------------------------}

procedure TOmHTMLEditor.InternalOnBrowserCommandStateChange(ASender: TObject; Command: Integer; Enable: WordBool);
begin
  if HasDocument then
  begin
    FIsBold := GetDocument.queryCommandState('Bold');
    FIsUnderLine := GetDocument.queryCommandState('Underline');
    FIsItalic := GetDocument.queryCommandState('Italic');
    FIsAlignLeft := GetDocument.queryCommandState('JustifyLeft');
    FIsAlignRight := GetDocument.queryCommandState('JustifyRight');
    FIsAlignCenter := GetDocument.queryCommandState('JustifyCenter');
    FIsBulletedList := GetDocument.queryCommandState('insertunorderedlist');
    FIsNumberedList := GetDocument.queryCommandState('insertorderedlist');
    if Assigned(FOnCommandChange) then
      FOnCommandChange(Self);
  end;
end;
{------------------------------------------------------------------------------}

end.

 

 

 

{*******************************************************}
{                                                       }
{       作者: 隐神                                      }
{                                                       }
{       日期: 2007.05.15                                }
{                                                       }
{       电邮: [email protected]                           }
{                                                       }
{       版权所有 (C) 2007 独家村一号                    }
{                                                       }
{*******************************************************}

unit uHtmlEdit;

interface

uses
  Windows, Messages, Forms, SysUtils, Classes, Controls, Graphics, OleCtrls,
  SHDocVw, Dialogs, ComCtrls, mshtml, Variants, ActiveX, StdCtrls, ExtCtrls,
  Clipbrd;

type
  {
  2D-Position 允许通过拖曳移动绝对定位的对象。
  AbsolutePosition 设定元素的 position 属性为“absolute”(绝对)。
  BackColor 设置或获取当前选中区的背景颜色。
  BlockDirLTR 目前尚未支持。
  BlockDirRTL 目前尚未支持。
  Bold 切换当前选中区的粗体显示与否。
  BrowseMode 目前尚未支持。
  Copy 将当前选中区复制到剪贴板。
  CreateBookmark 创建一个书签锚或获取当前选中区或插入点的书签锚的名称。
  CreateLink 在当前选中区上插入超级链接，或显示一个对话框允许用户指定要为当前选中区插入的超级链接的 URL。
  Cut 将当前选中区复制到剪贴板并删除之。
  Delete 删除当前选中区。
  DirLTR 目前尚未支持。
  DirRTL 目前尚未支持。
  EditMode 目前尚未支持。
  FontName 设置或获取当前选中区的字体。
  FontSize 设置或获取当前选中区的字体大小。
  ForeColor 设置或获取当前选中区的前景(文本)颜色。 )
  formatBlock 设置当前块格式化标签。
  Indent 增加选中文本的缩进。
  InlineDirLTR 目前尚未支持。
  InlineDirRTL 目前尚未支持。
  InsertButton 用按钮控件覆盖当前选中区。
  InsertFieldset 用方框覆盖当前选中区。
  InsertHorizontalRule 用水平线覆盖当前选中区。
  InsertIFrame 用内嵌框架覆盖当前选中区。
  InsertImage 用图像覆盖当前选中区。
  InsertInputButton 用按钮控件覆盖当前选中区。
  InsertInputCheckbox 用复选框控件覆盖当前选中区。
  InsertInputFileUpload 用文件上载控件覆盖当前选中区。
  InsertInputHidden 插入隐藏控件覆盖当前选中区。
  InsertInputImage 用图像控件覆盖当前选中区。
  InsertInputPassword 用密码控件覆盖当前选中区。
  InsertInputRadio 用单选钮控件覆盖当前选中区。
  InsertInputReset 用重置控件覆盖当前选中区。
  InsertInputSubmit 用提交控件覆盖当前选中区。
  InsertInputText 用文本控件覆盖当前选中区。
  InsertMarquee 用空字幕覆盖当前选中区。
  InsertOrderedList 切换当前选中区是编号列表还是常规格式化块。
  InsertParagraph 用换行覆盖当前选中区。
  InsertSelectDropdown 用下拉框控件覆盖当前选中区。
  InsertSelectListbox 用列表框控件覆盖当前选中区。
  InsertTextArea 用多行文本输入控件覆盖当前选中区。
  InsertUnorderedList 切换当前选中区是项目圆点符号列表。
  Italic 切换当前选中区斜体显示与否。
  JustifyCenter 将当前选中区在所在格式化块置中。
  JustifyFull 目前尚未支持。
  JustifyLeft 将当前选中区所在格式化块左对齐。
  JustifyNone 目前尚未支持。
  JustifyRight 将当前选中区所在格式化块右对齐。
  LiveResize 迫使 MSHTML 编辑器在缩放或移动过程中持续更新元素外观，而不是只在移动或缩放完成后更新。
  MultipleSelection 允许当用户按住 Shift 或 Ctrl 键时一次选中多于一个站点可选元素。
  Open 目前尚未支持。
  Outdent 减少选中区所在格式化块的缩进。
  OverWrite 切换文本状态的插入和覆盖。
  Paste 用剪贴板内容覆盖当前选中区。
  PlayImage 目前尚未支持。
  Print 打开打印对话框以便用户可以打印当前页。
  Redo 目前尚未支持。
  Refresh 刷新当前文档。
  Removeformat 从当前选中区中删除格式化标签。
  RemoveParaformat 目前尚未支持。
  SaveAs 将当前 Web 页面保存为文件。
  SelectAll 选中整个文档。
  SizeToControl 目前尚未支持。
  SizeToControlHeight 目前尚未支持。
  SizeToControlWidth 目前尚未支持。
  Stop 目前尚未支持。
  StopImage 目前尚未支持。
  StrikeThrough 目前尚未支持。
  Subscript 下标
  Superscript 上标
  UnBookmark 从当前选中区中删除全部书签。
  Underline 切换当前选中区的下划线显示与否。
  Undo 目前尚未支持。
  Unlink 从当前选中区中删除全部超级链接。
  Unselect 清除当前选中区的选中状态。
  }
  // 选择色彩对话窗
  TOnColorDialog = procedure(Sender: TObject; out vColor: TColor) of object;
  TEditCommander = class(TObject)
  private

    FHTMLDocument: IHTMLDocument2;
    FImageFolder: string;
    FOnColorDialog: TOnColorDialog;
    procedure SetFocus;
    procedure InsertHTML(const html: WideString);
    procedure SetOnColorDialog(const Value: TOnColorDialog);
  protected
    // InsertImage 插入图片 只留一个接口, 图片名必须由外部提供
    procedure InsertImage; overload; virtual;
  public
    SelectedTable: IHTMLElement;
    constructor Create(AHTMLDocument: IHTMLDocument2);
    // BackColor 突出显示
    procedure BackColor; overload;
    // BackColor 突出显示
    procedure BackColor(const AColor: TColor); overload;
    // Bold 加粗
    procedure Bold;
    // CreateLink 给选定对象添加超级连接
    procedure CreateLink;
    // 设置或获取当前选中区的字体。
    procedure FontName(const AFontName: string);
    // 设置或获取当前选中区的字体大小。
    procedure FontSize(const AFontSize: Integer);
    // ForeColor 字体颜色
    procedure ForeColor; overload;
    // ForeColor 字体颜色
    procedure ForeColor(const AColor: TColor); overload;
    //执行指令
    procedure Format(const Cmd: string);
    // htmlmode 切换HTML原始码
    //procedure HtmlMode;
    // indent 增加缩进量
    procedure InDent;
    // horizontalrule 水平线
    procedure InsertHorizontalRule;
    // InsertImage 插入图片
    procedure InsertImage(const AImageName: string); overload;
    //
    procedure InsertLineBreak;
    // 项目符号
    procedure InsertOrderedList;
    // inserttable 插入表格
    procedure InsertTable(const Col: Integer = 2; const Row: Integer = 2);
    // 切消项目符号
    procedure InsertUnOrderedList;
    function IsTableSelected: Boolean;
    function IsSelected: Boolean;
    // italic 斜体
    procedure Italic;
    // justifycenter 位置居中
    procedure JustifyCenter;
    // justifyfull 位置左右平等
    procedure JustifyFull;
    // justifyleft 位置靠左
    procedure JustifyLeft;
    // justifyright 位置靠右
    procedure JustifyRight;
    // orderedlist 顺序清单
    //procedure Orderedlist;
    // outdent 减少缩进量
    procedure OutDent;
    // popupeditor 放大
    //procedure Popupeditor;
    // 精除格式
    procedure RemoveFormat;
    //最后页
    procedure ScrollToBottom;
    //最顶页
    procedure ScrollToTop;
    // strikethrough 删除线
    procedure StrikeThrough;
    // subscript 下标
    procedure SubScript;
    // superscript 上标
    procedure SuperScript;
    // textindicator 字体例子
    //procedure Textindicator;
    // underline 下划线
    procedure UnderLine;
    // unorderedlist 无序清单
    //procedure Unorderedlist;
  published
    // 存放图片的临时目录
    property ImageFolder: string read FImageFolder write FImageFolder;
    // 调用色彩对话窗
    property OnColorDialog: TOnColorDialog read FOnColorDialog write
      SetOnColorDialog;
  end;

  THistoryBase = class(TComponent)
  private
    FActive: Boolean;
    procedure SetActive(const Value: Boolean);
  protected
    procedure Close; virtual; abstract;
    procedure Open; virtual; abstract;
  public
    procedure Write(const AText: string); virtual; abstract;
  published
    property Active: Boolean read FActive write SetActive default False;
  end;

  THistoryFile = class(THistoryBase)
  private
    procedure SetFilename(const Value: TFilename);
  protected
    FFilename: TFilename;
    FFileStream: TFileStream;
    procedure Close; override;
    procedure Open; override;
  public
    procedure Write(const AText: string); override;
  published
    property Filename: TFilename read FFilename write SetFilename;
  end;

  TOnClipboardEvent = procedure(Sender: TObject; AClipboard: TClipboard) of
    object;
  TOnKeyHyperlink = procedure(Sender: TObject; var vHyperlink: string) of
    object;

  THtmlEdit = class(TWebBrowser)

  private
    FEdit: TEditCommander;
    FFont: TFont;
    FHistory: THistoryBase;
    FHTMLDocument: IHTMLDocument2;
    FImageFolder: string;
    FOnKeyHyperlink: TOnKeyHyperlink;
    FOnPaste: TOnClipboardEvent;
    FReadOnly: Boolean;
    FCharSet: string;
    function GetHTML: WideString;
    function GetText: WideString;
    procedure OnMessage(var Msg: TMsg; var Handled: Boolean);
    // 17,
    procedure SetHTML(const Value: WideString);
    // 17,
    procedure SetImageFolder(const Value: string);
    // 17,
    procedure SetReadOnly(const Value: Boolean);
    procedure SetCharSet(const Value: string);

  public
    constructor Create(AOwner: TComponent); override;
    // Forms.Application.OnMessage := Self.OnMessage;
    destructor Destroy; override;
    // 添加
    procedure Append(AMessage: string);
    // 清除
    procedure Clear;
    // 复制
    procedure Copy;
    // 剪切
    procedure Cut;
    // 删除
    //procedure Delete;
    //插入内容
    procedure Insert(AMessage: string);
    // 从文件加载
    procedure LoadFromFile(const AFileName: string);
    // 从流加载
    procedure LoadFromStream(AHtmlStrem: TStream);
    // 新建
    procedure New;
    // 打开
    procedure Open(const AFileName: string);
    // 粘贴
    procedure Paste;
    // 打印
    procedure Print(const APreview: Boolean = FALSE);
    // 页面设置
    procedure PrintPageSetup;
    // 打印预览
    procedure PrintPreview;
    // 重做
    procedure Redo;
    // 保存
    procedure Save;
    // 另存为
    procedure SaveAs;
    // 保存到指定文件
    procedure SaveToFile(const FileName: string);
    // 保存到流
    procedure SaveToStream(Stream: TStream);
    // 全选
    procedure SelectAll;
    // 撒消
    procedure Undo;
    // 写入内容
    procedure Write(AHTML: string);
    //
    procedure SetFocus; override;
    // 编辑指令
    property Edit: TEditCommander read FEdit;
    // 只读属性
    property ReadOnly: Boolean read FReadOnly write SetReadOnly;
    function CanFocus: Boolean; override;

  published
    property TabStop default True;
    property Align;
    property DragCursor;
    property DragMode;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property TabOrder;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnStartDrag;
    property CharSet: string read FCharSet write SetCharSet;

    // 默认字体
    property Font: TFont read FFont write FFont;
    // 聊天记录
    property History: THistoryBase read FHistory write FHistory;
    // 内容的HTML格式
    property HTML: WideString read GetHTML write SetHTML;
    // 图片文件临时存放路径
    property ImageFolder: string read FImageFolder write SetImageFolder;
    // 内容的文本格式
    property Text: WideString read GetText;
    // 点击了超联接
    property OnKeyHyperlink: TOnKeyHyperlink read FOnKeyHyperlink write
      FOnKeyHyperlink;
    // 粘贴事件
    property OnPaste: TOnClipboardEvent read FOnPaste write FOnPaste;
  end;

procedure Register;

implementation

uses uMD5;

procedure Register;
begin
  RegisterComponents('HtmlEdit', [THtmlEdit]);
  RegisterComponents('HtmlEdit', [THistoryFile]);
end;

{ THtmlEdit }

{
******************************** TEditCommander ********************************
}

constructor TEditCommander.Create(AHTMLDocument: IHTMLDocument2);
begin
  //inherited;
  FHTMLDocument := AHTMLDocument;
end; { TEditCommander.Create }

procedure TEditCommander.BackColor;
var
  Color: TColor;
begin
  if Assigned(FOnColorDialog) then
    FOnColorDialog(Self, Color);
  BackColor(Color);

end; { TEditCommander.BackColor }

procedure TEditCommander.BackColor(const AColor: TColor);
begin
  FHTMLDocument.execCommand('BackColor', True, AColor);
  SetFocus;
end; { TEditCommander.BackColor }

procedure TEditCommander.Bold;
begin
  Format('Bold');
end; { TEditCommander.Bold }

procedure TEditCommander.CreateLink;
begin
  Format('CreateLink');
end; { TEditCommander.CreateLink }

procedure TEditCommander.ForeColor;
var
  Color: TColor;
begin
  if Assigned(FOnColorDialog) then
    FOnColorDialog(Self, Color);

  ForeColor(Color);

end; { TEditCommander.ForeColor }

procedure TEditCommander.ForeColor(const AColor: TColor);
begin
  FHTMLDocument.execCommand('ForeColor', True, AColor);
  SetFocus;
end; { TEditCommander.ForeColor }

procedure TEditCommander.Format(const Cmd: string);
begin
  FHTMLDocument.execCommand(Cmd, True, True);
  SetFocus;
end; { TEditCommander.Format }

//procedure TEditCommander.HtmlMode;
//begin
//  //暂未支持
//end; { TEditCommander.HtmlMode }

procedure TEditCommander.InDent;
begin
  Format('Indent');
end; { TEditCommander.InDent }

procedure TEditCommander.InsertHorizontalRule;
begin
  Format('InsertHorizontalRule');
end; { TEditCommander.InsertHorizontalRule }

procedure TEditCommander.InsertHTML(const html: WideString);
begin
  if LowerCase(FHTMLDocument.selection.type_) <> 'none' then
    FHTMLDocument.selection.clear;
  (FHTMLDocument.selection.createRange as IHTMLTxtRange).pasteHTML(html);

  SetFocus;
end; { TEditCommander.InsertHTML }

procedure TEditCommander.InsertImage;
begin
  Format('InsertImage');
end; { TEditCommander.InsertImage }

procedure TEditCommander.InsertImage(const AImageName: string);
var
  TargetName: string;
begin

  if FileExists(AImageName) and DirectoryExists(FImageFolder) then
  begin
    //返回图片的新名
    TargetName := StrMD5(FormatDateTime('yyyymmddhhnnss', Now) +
      IntToStr(GetTickCount)) + ExtractFileExt(AImageName);

    //将图片以新名称复制到指定的文件夹
    CopyFile(PChar(AImageName), PChar(FImageFolder + TargetName), False);

    InsertHTML('');
  end;

  SetFocus;
end; { TEditCommander.InsertImage }

procedure TEditCommander.InsertLineBreak;
begin
  InsertHTML('
');
  (FHTMLDocument.parentWindow as IHTMLWindow2).focus;
end; { TEditCommander.InsertLineBreak }

procedure TEditCommander.InsertOrderedList;
begin
  Format('InsertOrderedList');
end; { TEditCommander.InsertOrderedList }

procedure TEditCommander.InsertTable(const Col: Integer = 2; const Row: Integer
  = 2);
var
  ColCnt, RowCnt: Integer;
  sTable: string;
begin
  //sTable是表格的Html代码
  sTable := '';
  for RowCnt := 1 to Row do
  begin
    sTable := sTable + '';
    for ColCnt := 1 to Col do
      sTable := sTable + '';
    sTable := sTable + '';
  end;
  sTable := sTable + '';

  //插入Html表格
  InsertHTML(sTable);

  SetFocus;
end; { TEditCommander.InsertTable }

procedure TEditCommander.InsertUnOrderedList;
begin
  Format('InsertUnOrderedList');
end; { TEditCommander.
 }
function TEditCommander.IsSelected: Boolean;
begin
  Result := False;
  if LowerCase(FHTMLDocument.selection.type_) <> 'none' then
    Result := True;
end;


function TEditCommander.IsTableSelected: Boolean;
var
  oControlRange: IHTMLControlRange;
begin
  Result := False;
  if UpperCase(FHTMLDocument.selection.type_) = 'CONTROL' then
  begin
    oControlRange := (FHTMLDocument.selection.createRange as IHTMLControlRange);
    if UpperCase((oControlRange.item(0) as IHTMLElement).tagName) = 'TABLE' then
    begin
      SelectedTable := ((FHTMLDocument.selection.createRange as
        IHTMLControlRange).item(0)) as IHTMLElement;
      Result := True;
    end;
  end;
end; { TEditCommander.IsTableSelected }

procedure TEditCommander.Italic;
begin
  Format('Italic');
end; { TEditCommander.Italic }

procedure TEditCommander.JustifyCenter;
begin
  Format('JustifyCenter');
end; { TEditCommander.JustifyCenter }

procedure TEditCommander.JustifyFull;
begin
  Format('JustifyFull');
end; { TEditCommander.JustifyFull }

procedure TEditCommander.JustifyLeft;
begin
  Format('JustifyLeft');
end; { TEditCommander.JustifyLeft }

procedure TEditCommander.JustifyRight;
begin
  Format('JustifyRight');
end; { TEditCommander.JustifyRight }

//procedure TEditCommander.Orderedlist;
//begin
//  //暂未支持
//end; { TEditCommander.Orderedlist }

procedure TEditCommander.OutDent;
begin
  Format('Outdent');
end; { TEditCommander.OutDent }

//procedure TEditCommander.Popupeditor;
//begin
//  //暂未支持
//end; { TEditCommander.Popupeditor }

procedure TEditCommander.RemoveFormat;
begin
  Format('Removeformat');
end; { TEditCommander.RemoveFormat }

procedure TEditCommander.ScrollToBottom;
begin
  if Assigned(FHTMLDocument) then
    FHTMLDocument.parentWindow.scrollBy(0, (FHTMLDocument.body as
      IHTMLElement2).scrollHeight);
  SetFocus;
end; { TEditCommander.ScrollToBottom }

procedure TEditCommander.ScrollToTop;
begin
  if Assigned(FHTMLDocument) then
    FHTMLDocument.parentWindow.scrollTo(0, 0);
  SetFocus;    
end; { TEditCommander.ScrollToTop }

procedure TEditCommander.SetOnColorDialog(const Value: TOnColorDialog);
begin
  FOnColorDialog := Value;
end; { TEditCommander.SetOnColorDialog }

procedure TEditCommander.StrikeThrough;
begin
  Format('Strikethrough');
end; { TEditCommander.StrikeThrough }

procedure TEditCommander.SubScript;
begin
  Format('Subscript');
end; { TEditCommander.SubScript }

procedure TEditCommander.SuperScript;
begin
  Format('Superscript');
end; { TEditCommander.SuperScript }

//procedure TEditCommander.Textindicator;
//begin
//  //暂不支持
//end; { TEditCommander.Textindicator }

procedure TEditCommander.UnderLine;
begin
  Format('Underline');
end; { TEditCommander.UnderLine }

//procedure TEditCommander.Unorderedlist;
//begin
//  //暂不支持
//end; { TEditCommander.Unorderedlist }

{
********************************* THistoryBase *********************************
}

procedure THistoryBase.SetActive(const Value: Boolean);
begin
  if FActive <> Value then
  begin
    FActive := Value;
    if FActive then
      Open
    else
      Close;
  end;
end; { THistoryBase.SetActive }

{
********************************* THistoryFile *********************************
}

procedure THistoryFile.Close;
begin
  FreeAndNil(FFileStream);
end; { THistoryFile.Close }

procedure THistoryFile.Open;
begin

  if not FileExists(Filename) then
  begin
    FFileStream := TFileStream.Create(Filename, fmCreate or fmShareDenyWrite);
  end
  else
  begin
    FFileStream := TFileStream.Create(Filename, fmOpenReadWrite or
      fmShareDenyWrite);
    FFileStream.Position := FFileStream.Size;
  end;

end; { THistoryFile.Open }

procedure THistoryFile.SetFilename(const Value: TFilename);
begin
  FFilename := Value;
  if Active then
    Close;
  Open;
end; { THistoryFile.SetFilename }

procedure THistoryFile.Write(const AText: string);
begin
  if Active and (Length(AText) > 0) then
  begin
    FFileStream.WriteBuffer(AText[1], Length(AText));
  end;
end; { THistoryFile.Write }

{
********************************** THtmlEdit ***********************************
}

constructor THtmlEdit.Create(AOwner: TComponent);

  function GetTempDir: string;
  var
    TmpDir: array[0..255] of Char;
  begin
    GetTempPath(255, @TmpDir);
    Result := StrPas(TmpDir);
    TmpDir := '';
  end;

begin
  inherited Create(AOwner);
  Self.Navigate('about:blank');
  FHTMLDocument := IHTMLDocument2(Self.Document);
  //编辑指令
  FEdit := TEditCommander.Create(FHTMLDocument);

  //缺省是系统临时文件夹
  ImageFolder := GetTempDir;

  ReadOnly := False;

  CharSet := 'gb2312';
  //  FHtmlFont := THtmlFont.Create(HTMLDocument);

  //  Forms.Application.OnMessage := Self.OnMessage;
end; { THtmlEdit.Create }

destructor THtmlEdit.Destroy;
begin
  FreeAndNil(FEdit);
  inherited;
end; { THtmlEdit.Destroy }

procedure THtmlEdit.Append(AMessage: string);
begin
  Self.OleObject.document.write(AMessage);
end; { THtmlEdit.Add }

procedure THtmlEdit.Clear;
begin
  Self.New;
end; { THtmlEdit.Clear }

procedure THtmlEdit.Copy;
begin
  Self.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT); //12,
end; { THtmlEdit.Copy }

procedure THtmlEdit.Cut;
begin
  Self.ExecWB(OLECMDID_CUT, OLECMDEXECOPT_DODEFAULT); //11,
end; { THtmlEdit.Cut }

//procedure THtmlEdit.Delete;
//begin
//  Self.ExecWB(OLECMDID_NEW, OLECMDEXECOPT_DODEFAULT);
//end; { THtmlEdit.Delete }

function THtmlEdit.GetHTML: WideString;
begin
  Result := FHTMLDocument.body.outerHTML;
end; { THtmlEdit.GetHTML }

function THtmlEdit.GetText: WideString;
begin
  Result := FHTMLDocument.body.outerText;
end; { THtmlEdit.GetText }

procedure THtmlEdit.Insert(AMessage: string);
begin
  if LowerCase(FHTMLDocument.selection.type_) <> 'none' then
    FHTMLDocument.selection.clear;
  (FHTMLDocument.selection.createRange as IHTMLTxtRange).pasteHTML(AMessage);
end; { THtmlEdit.Insert }

procedure THtmlEdit.LoadFromFile(const AFileName: string);
var
  Stream: TStream;
begin
  if FileExists(AFileName) then
  begin
    Stream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
    try
      LoadFromStream(Stream);
    finally
      Stream.Free;
    end;
  end;
end; { THtmlEdit.LoadFromFile }

procedure THtmlEdit.LoadFromStream(AHtmlStrem: TStream);
var
  Size: Integer;
  S: string;
begin
  try
    Size := AHtmlStrem.Size - AHtmlStrem.Position;
    SetString(S, nil, Size);
    AHtmlStrem.Read(Pointer(S)^, Size);
    Self.OleObject.document.close();
    Self.OleObject.document.clear();
    Self.OleObject.document.write(S);
  finally
  end;
end; { THtmlEdit.LoadFromStream }

procedure THtmlEdit.New;
var
  Html: string;
begin

  //Self.ExecWB(OLECMDID_NEW, OLECMDEXECOPT_DODEFAULT); //2,

  Html := ''#13#10;
  Html := Html + ''#13#10;
  Html := Html + ''#13#10;
  //Html := Html + ''#13#10;
  Html := Html + ''#13#10;
  Html := Html + ''#13#10;
  Html := Html + ''#13#10;
  Html := Html + ''#13#10;
  Html := Html + ''#13#10;
  Self.OleObject.document.close();
  Self.OleObject.document.clear();
  Self.OleObject.document.write(HTML);

end; { THtmlEdit.NewDocument }

procedure THtmlEdit.OnMessage(var Msg: TMsg; var Handled: Boolean);
var
  p: tpoint;
  TheName: array[0..255] of char;
begin
  //本函数放在 Forms.Application.OnMessage := Self.OnMessage;
  if (msg.message = WM_RBUTTONDOWN) then
  begin

    GetCursorPos(p);
    //取得当前鼠标的控件名。
    GetClassName(WindowFromPoint(p), TheName, 255);
    //todo: 禁用鼠标右键不行，因为标题会变
    if TheName = 'Internet Explorer_Server' then
    begin
      if Assigned(Self.PopupMenu) then
        Self.PopupMenu.Popup(P.X, P.Y);
      Handled := true;
    end;
  end;

end; { THtmlEdit.OnMessage }

procedure THtmlEdit.Paste;
begin
  {todo:
  0. 先预处理 粘贴板, 如果是 位图 则先存为 jpg 后再上超联接
  1. 判断事件存在，并粘贴板属于自己  GetClipboardOwner
  2. 如果 文字 CF_TEXT、位图CF_BITMAP、元文件CF_METAFILEPICT
  case of
  CF_TEXT:
  IF 超联接。。。

}
  Self.ExecWB(OLECMDID_PASTE, OLECMDEXECOPT_DODEFAULT); //13,
end; { THtmlEdit.Paste }

procedure THtmlEdit.Print(const APreview: Boolean = FALSE);
begin
  if APreview then
    Self.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT)
  else
    Self.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT);
end; { THtmlEdit.Print }

procedure THtmlEdit.PrintPageSetup;
begin
  Self.ExecWB(OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT);
end; { THtmlEdit.PrintPageSetup }

procedure THtmlEdit.PrintPreview;
begin
  Self.ExecWB(OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT)
end; { THtmlEdit.PrintPreview }

procedure THtmlEdit.Redo;
begin
  Self.ExecWB(OLECMDID_REDO, OLECMDEXECOPT_DODEFAULT); //16,
end; { THtmlEdit.Redo }

procedure THtmlEdit.Save;
begin
  Self.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DODEFAULT); //3,
end; { THtmlEdit.Save }

procedure THtmlEdit.SaveAs;
begin
  Self.ExecWB(OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT); //4,
end; { THtmlEdit.SaveAs }

procedure THtmlEdit.SaveToFile(const FileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;

end; { THtmlEdit.SaveToFile }

procedure THtmlEdit.SaveToStream(Stream: TStream);
var
  S: string;
begin
  S := string(Self.Html);
  Stream.WriteBuffer(Pointer(S)^, Length(S));
end; { THtmlEdit.SaveToStream }

procedure THtmlEdit.SelectAll;
begin
  Self.ExecWB(OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT); //17,
end; { THtmlEdit.SelectAll }

procedure THtmlEdit.SetHTML(const Value: WideString);
var
  Html: Variant;
begin
  Html := VarArrayCreate([0, 0], varVariant);
  Html[0] := Value;
  FHTMLDocument.write(pSafearray(TVarData(Html).VArray));

end; { THtmlEdit.SetHTML }

procedure THtmlEdit.SetImageFolder(const Value: string);
begin
  FImageFolder := Value;
  FEdit.FImageFolder := Value;
end; { THtmlEdit.SetImageFolder }

procedure THtmlEdit.SetReadOnly(const Value: Boolean);
begin
  FReadOnly := Value;
  if FReadOnly then
    FHTMLDocument.designMode := 'Off' //非编辑模式
  else
    FHTMLDocument.designMode := 'On'; //编辑模式
end; { THtmlEdit.SetReadOnly }

procedure THtmlEdit.Undo;
begin
  Self.ExecWB(OLECMDID_UNDO, OLECMDEXECOPT_DODEFAULT); //15,
end; { THtmlEdit.Undo }

procedure THtmlEdit.Write(AHTML: string);
begin
  Self.New;
  Self.OleObject.document.write(AHTML);
end; { THtmlEdit.Write }

procedure TEditCommander.FontName(const AFontName: string);
begin
  //FontName 设置或获取当前选中区的字体。
  FHTMLDocument.execCommand('FontName', TRUE, '"' + AFontName + '"');
  SetFocus;
end;

procedure TEditCommander.FontSize(const AFontSize: Integer);
begin
  //FontSize 设置或获取当前选中区的字体大小。
  case AFontSize of
    1..7: FHTMLDocument.execCommand('FontSize', TRUE, AFontSize);
  else
    FHTMLDocument.execCommand('FontSize', TRUE, 3);
  end;
  SetFocus;
end;

procedure THtmlEdit.SetCharSet(const Value: string);
begin
  FCharSet := Value;
  FHTMLDocument.Set_CharSet(FCharSet);
end;

procedure THtmlEdit.Open(const AFileName: string);
begin
  LoadFromFile(AFileName);
end;

procedure THtmlEdit.SetFocus;
begin
  inherited;
  FHTMLDocument.parentWindow.focus;
end;

procedure TEditCommander.SetFocus;
begin
  FHTMLDocument.parentWindow.focus;
end;

function THtmlEdit.CanFocus: Boolean;
var
  Control: TWinControl;
  Form: TCustomForm;
begin
  Result := False;
  Form := GetParentForm(Self);
  if Form <> nil then
  begin
    Control := Self;
    while Control <> Form do
    begin
      if not Control.Enabled then //修改
      Exit;
      Control := Control.Parent;
    end;
    Result := True;
  end;

end;

initialization
  OleInitialize(nil);
finalization
  try
    OleUninitialize;
  except
  end;
end.

 

 

unit MainFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OmHTMLEditor, ImgList, ToolWin, ComCtrls, StdCtrls, RxCombos,
  Spin;

type
  TForm1 = class(TForm)
    OmHTMLEditor1: TOmHTMLEditor;
    ToolBar1: TToolBar;
    ToolbarImages: TImageList;
    tbOpenDocument: TToolButton;
    OpenDialog1: TOpenDialog;
    tbEditHTML: TToolButton;
    ToolButton1: TToolButton;
    ToolButton2: TToolButton;
    btnBold: TToolButton;
    ToolButton3: TToolButton;
    btnItalic: TToolButton;
    ToolButton4: TToolButton;
    btnUnderline: TToolButton;
    ToolButton5: TToolButton;
    btnFGColor: TToolButton;
    ToolButton6: TToolButton;
    dbSaveDocument: TToolButton;
    ToolButton7: TToolButton;
    btnCopy: TToolButton;
    ToolButton8: TToolButton;
    btnPaste: TToolButton;
    ToolButton9: TToolButton;
    btnCut: TToolButton;
    ToolButton10: TToolButton;
    btnRedo: TToolButton;
    btn1: TToolButton;
    btnUndo: TToolButton;
    ToolButton11: TToolButton;
    btnIndentLeft: TToolButton;
    btnIndentRight: TToolButton;
    ToolButton12: TToolButton;
    btn2: TToolButton;
    btnBulletedList: TToolButton;
    ToolButton13: TToolButton;
    btnAlignLeft: TToolButton;
    btn3: TToolButton;
    btnAlignCenter: TToolButton;
    btn4: TToolButton;
    btnAlignRight: TToolButton;
    ToolButton14: TToolButton;
    btnInsertImage: TToolButton;
    ToolButton15: TToolButton;
    btnInserttable: TToolButton;
    ToolButton16: TToolButton;
    btnselectall: TToolButton;
    FontComboBox1: TFontComboBox;
    ComboBox1: TComboBox;
    ToolButton17: TToolButton;
    ToolButton18: TToolButton;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    OmHTMLEditor2: TOmHTMLEditor;
    OmHTMLEditor3: TOmHTMLEditor;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    OmHTMLEditor4: TOmHTMLEditor;
    OmHTMLEditor5: TOmHTMLEditor;
    OmHTMLEditor6: TOmHTMLEditor;
    btn5: TToolButton;
    btn_html: TToolButton;
    ToolButton19: TToolButton;
    btn_text: TToolButton;
    ToolButton20: TToolButton;
    btn_clear: TToolButton;
    Button2: TButton;
    ToolButton21: TToolButton;
    cbb_linehieght: TComboBox;
    ToolButton23: TToolButton;
    btn_print: TToolButton;
    procedure tbOpenDocumentClick(Sender: TObject);
    procedure tbEditHTMLClick(Sender: TObject);
    procedure dbSaveDocumentClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnInserttableClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnselectallClick(Sender: TObject);
    procedure FontComboBox1Change(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure btn_htmlClick(Sender: TObject);
    procedure btn_textClick(Sender: TObject);
    procedure btn_clearClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure cbb_linehieghtChange(Sender: TObject);
    procedure btn_printClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure ConnectButtonsToCommnads;
    procedure AppException(Sender: Tobject; E: Exception);
  end;

var
  Form1: TForm1;

implementation

uses TableForm;

{$R *.dfm}



procedure TForm1.tbOpenDocumentClick(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    Self.OmHTMLEditor1.LoadFromFile(OpenDialog1.FileName);
  end;
end;

procedure TForm1.tbEditHTMLClick(Sender: TObject);
begin
  Self.OmHTMLEditor1.Edit;
end;

procedure TForm1.dbSaveDocumentClick(Sender: TObject);
begin
  Self.OmHTMLEditor1.SaveAs;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ConnectButtonsToCommnads;
  Application.OnException := AppException;
end;

procedure TForm1.AppException(Sender: Tobject; E: Exception);
begin
  ShowMessage('错误是：' + (e.Message));
end;


procedure TForm1.ConnectButtonsToCommnads;
begin

  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecBulletList, Self.btnBulletedList);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecCopy, Self.btnCopy);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecPaste, Self.btnPaste);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecCut, Self.btnCut);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecRedo, Self.btnRedo);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecUndo, Self.btnUndo);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecForegroundColor, Self.btnFGColor);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecIdentLeft, Self.btnIndentLeft);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecIdentRight, Self.btnIndentRight);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecInsertImage, Self.btnInsertImage);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecItalic, Self.btnItalic);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecUnderLine, Self.btnUnderline);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecAlignLeft, Self.btnAlignLeft);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecAlignCenter, Self.btnAlignCenter);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecAlignRight, Self.btnAlignRight);
  Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecBold, Self.btnBold);
  //Self.OmHTMLEditor1.ConnectClickableControlToCommand(hecInsertTable    ,Self.btnInserttable    );

end;

procedure TForm1.btnInserttableClick(Sender: TObject);
var
  row, col: integer;
begin
  Form2 := TForm2.create(self);
  Form2.ShowModal;
  row := Form2.row;
  col := Form2.col;
  Form2.Free;
  OmHTMLEditor1.InsertTable(col, row);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
   ;
end;

procedure TForm1.btnselectallClick(Sender: TObject);
begin
   OmHTMLEditor1.SelectAll;
end;

procedure TForm1.FontComboBox1Change(Sender: TObject);
begin
  OmHTMLEditor1.FontName(FontComboBox1.Text);
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
var
  fontsize :integer;
begin
  fontsize :=  StrToInt(Copy(ComboBox1.Text,Pos('(',ComboBox1.Text)+1,1))  ;
  OmHTMLEditor1.FontSize(fontsize);
end;
procedure TForm1.btn_htmlClick(Sender: TObject);
begin
  ShowMessage( OmHTMLEditor1.HTML);
end;

procedure TForm1.btn_textClick(Sender: TObject);
begin
   ShowMessage( OmHTMLEditor1.Text);
end;

procedure TForm1.btn_clearClick(Sender: TObject);
begin
  OmHTMLEditor1.Clear;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if OmHTMLEditor2.IsSelected then
    ShowMessage('试题正文被选了')
  else   if OmHTMLEditor3.IsSelected then
    ShowMessage('选项A被选了');
end;

procedure TForm1.cbb_linehieghtChange(Sender: TObject);
var
  linehieght :double;
begin
  linehieght :=  strtofloat(Copy(cbb_linehieght.Text,Pos('(',cbb_linehieght.Text)+1,1))  ;
  OmHTMLEditor1.LineHeight(linehieght);
end;

procedure TForm1.btn_printClick(Sender: TObject);
begin
  OmHTMLEditor1.PrintPreview;
end;

end.