OmHTMLEditor

最新推荐文章于 2013-05-15 17:04:23 发布
最新推荐文章于 2013-05-15 17:04:23 发布
阅读量983 收藏 1
点赞数
分类专栏： Delphi
版权声明：本文为博主原创文章，遵循 CC 4.0 BY-SA 版权协议，转载请附上原文出处链接和本声明。
本文链接：https://blog.csdn.net/kuaileren003/article/details/8815032
版权 
{------------------------------------------------------------------------------    }
{                       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 := '<table border=1 cellspacing=0 style="border-collapse:collapse" bordercolor="#000000">';
  for RowCnt := 1 to Row do
  begin
    sTable := sTable + '<tr>';
    for ColCnt := 1 to Col do
      sTable := sTable + '<td> </td>';
    sTable := sTable + '</tr>';
  end;
  sTable := sTable + '</table>';
  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] := '<HTML><BODY></BODY></HTML>';
  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                                }
{                                                       }
{       电邮: Dot.net@tom.com                           }
{                                                       }
{       版权所有 (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('<img src="file://' + FImageFolder + TargetName + '" >');
  end;

  SetFocus;
end; { TEditCommander.InsertImage }

procedure TEditCommander.InsertLineBreak;
begin
  InsertHTML('<BR>');
  (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 := '<TABLE border=1  style="border-collapse: collapse;border-color: black"  >';
  for RowCnt := 1 to Row do
  begin
    sTable := sTable + '<TR>';
    for ColCnt := 1 to Col do
      sTable := sTable + '<TD> </TD>';
    sTable := sTable + '</TR>';
  end;
  sTable := sTable + '</TABLE>';

  //插入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 := '<HTML>'#13#10;
  Html := Html + '<HEAD>'#13#10;
  Html := Html + '<META NAME="GENERATOR" CONTENT="PP HTML-WRITER">'#13#10;
  //Html := Html + '<TITLE>' + S + '</TITLE>'#13#10;
  Html := Html + '<TITLE>NewDocument</TITLE>'#13#10;
  Html := Html + '</HEAD>'#13#10;
  Html := Html + '<BODY>'#13#10;
  Html := Html + '</BODY>'#13#10;
  Html := 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.


 

 

 


 

王姐
关注
  • 0
    点赞
  • 踩
  • 1
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
专栏目录
我用fastReport打印时，超出一页的内容如何让其自动换页？[问题点数:20分，结帖人:zjhjp]
08-14 6946
我用fastReport打印时，超出一页的内容如何让其自动换页？[问题点数:20分，结帖人:zjhjp]     在主项数据一栏上点右键，有一个“分隔”，选中即可     fastreport问题:如何把form1上的richedit1.text在fastreport上的rich1(TfrRichView)上打印出来?[问题点数:0分，结帖人:]   这样是可以按格式打印出去,但是
dbf 连接字符串问题 .
06-26 1622
解决ERROR [42S02] [Microsoft][ODBC Visual FoxPro Driver]File 'xxx.dbf' does not exist. 的问题: 是因为连接FoxPro的连接字符串存在问题 "Driver={Microsoft Visual FoxPro Driver};SourceType=DBF;SourceDB=c:/TestTzm/T
RSA算法-公开密钥加密算法
07-09 1406
RSA1978年，MIT的Rivest、Shamir、Adleman提出RSA算法 非对称加密（公开密钥加密）密码学的一次革命，定义： KA≠ KB ， KA、E和D公开 特点：    基于数论原理(大数分解难题)    是目前应用最广泛的公钥加密算法    属于块加密算法 在数论，对正整数n，欧拉函数是少于或等于n的数中与n互质的数的数目。此函数以其首名研究者欧拉命名，它又称
JQUERY + UPLOADFY 上传图片并刷新
02-21 1102
//保存照片 @RequestMapping(params = "method=savePictureinfo") public String savePictureinfo(HttpServletRequest request) throws Exception { String idcard = request.getParameter("idcard"); String base
rxrichedit 内容 转换 成 HTMLEDT
05-08 821
unit MainForm; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls, Grids, DBGrids, StdCtrls, DB, ADODB, ExtCtrls, RxRichEd, Buttons, Ex
DELPHI 中如何安装第三方控件？
09-21 566
1 只有一个DCU文件的组件。DCU文件是编译好的单元文件，这样的组件是作者不想把源 码公布。一般来说，作者必须说明此组件适合Delphi的哪种版本，如果版本不对，在安装时 就会出现错误。也正是因为没有源码，给使用者带来了不便，那就是一旦Delphi版本升级， 此组件就不能再使用了，当然有的作者给出了几种版本的DCU文件，用户根据需要选择使用。 这样的组件的安装方法是：在Component
StrDiffThread
05-15 483
{--------------------------------------------------------------} {算法介绍：} {题库系统按5000一组分组比较，5000道题内开启10个线程，分别从     } {0,500,1000,1500,2000,2500,3000,3500,4000,4500位置开始与其后的所有试题比较} {比较完成返回比较结果；等待所有500
用Delphi 6 .7开发简单ActiveX控件
12-20 477
1.打开Delphi 2.File->New->Other->ActiveX->Active Form 3.弹出Active Form Wizard窗口，采用默认配置，单击“OK” 4.出现Form设计界面，这里添加一个Button和一个Edit控件 5.双击Button，添加事件处理代码 procedure TActiveFormX.Button1Cli
delphi ocx在IE8下调试不能断点的问题
04-13 456
regedit→ HKEY_LOCAL_MACHINE →SOFTWARE→Microsoft →   Internet Explorer→Main。在Main里新建一个DWORD类型名为TabProcGrowth值为0。
EXE文件自我修改
04-09 438
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, ComCtrls; type TPackage = packed record {定义结构 TPackage} s
线程
01-03 417
unit UMainForm; interface uses   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   Dialogs, StdCtrls, Buttons, DB, MemDS, DBAccess, Ora,UThread; type   TForm1 = class(
NetFunc
01-24 400
unit NetFunc; interface uses SysUtils, Windows, dialogs, winsock, Classes, ComObj, WinInet, Variants; //错误信息常量 const C_Err_GetLocalIp = '获取本地ip失败'; C_Err_GetNameByIpAddr = '获取主机名失败'; C_Err_
题库总题量
04-13 390
unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; { 题库总题量按每组C_groupCnt道题进行分若干组,组内开启C_threadCnt个线程, 每个线程处理perCnt= C_gro
WindowFunc
01-24 304
unit WindowFunc; interface uses SysUtils, Windows, dialogs, winsock, Classes, ComObj, WinInet, Variants, Graphics, NB30, Registry, ShellAPI; type TMemoryStatusEx = packed record dwLength
简历-求职简历-word-文件-简历模版免费分享-应届生-高颜值简历模版-个人简历模版-简约大气-大学生在校生-求职-实习
08-25
简历-求职简历-word-文件-简历模版免费分享-应届生-高颜值简历模版-个人简历模版-简约大气-大学生在校生-求职-实习 简历是展示个人经历、技能和能力的重要文档，以下是一个常见的简历格式和内容模板，供您参考： 简历格式： 头部信息：包括姓名、联系方式（电话号码、电子邮件等）、地址等个人基本信息。 求职目标（可选）：简短描述您的求职意向和目标。 教育背景：列出您的教育经历，包括学校名称、所学专业、就读时间等。 工作经验：按时间顺序列出您的工作经历，包括公司名称、职位、工作时间、工作职责和成就等。 技能和能力：列出您的专业技能、语言能力、计算机技能等与职位相关的能力。 实习经验/项目经验（可选）：如果您有相关实习或项目经验，可以列出相关信息。 获奖和荣誉（可选）：列出您在学术、工作或其他领域获得的奖项和荣誉。 自我评价（可选）：简要描述您的个人特点、能力和职业目标。 兴趣爱好（可选）：列出您的兴趣爱好，展示您的多样性和个人素质。 参考人（可选）：如果您有可提供推荐的人员，可以在简历中提供其联系信息。 简历内容模板： 姓名: 联系方式: 地址: 求职目标: （简短描述您的求职意
用VC++实现USB接口读写数据的程序.zip
08-25
用VC++实现USB接口读写数据的程序.zip
ant-design-4.2.5.zip
最新发布
08-25
ant-design，一套企业级 UI 设计语言和 React 组件库 提炼自企业级中后台产品的交互语言和视觉风格 开箱即用的高质量 React 组件
基于微信小程序校友会系统的实现设计与实现.docx
08-25
基于微信小程序校友会系统的实现设计与实现.docx
Java零基础极速入门(7天)
08-25
Java零基础极速入门(7天)
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值