求 delphi html编辑器 如图

Question

我用过 MSHTML Editor， 是开源的，不过版本很老了，早就不更新了，升级到 XE5后就不用这个控件了，直接用TWebbower写了一个。我也一直在找过可以编辑html的组件，一直没有找到合适，收费的也找过没有找到。

Answer 1

MSHTML Editor 别用了 楼上说的对
还是用twebrowser自己写一个
我这里就是自己写一个，是可以用的 
代码如下： 我是写成frame 其他窗口调用
unit unt_fraHtmlEdit;interfaceuses
  Classes, Controls, Forms, SysUtils, Windows, RzPanel, RzButton, Vcl.ComCtrls,
  RzCmboBx, Dialogs, ExtDlgs, ImgList, OleCtrls, StdCtrls, ExtCtrls, MSHTML,
  Vcl.Graphics, Winapi.Messages, SHDocVw, cxGraphics, cxControls, StrUtils,
  cxLookAndFeels, cxLookAndFeelPainters, cxContainer, cxEdit, cxTextEdit, cxMemo;type
  TfraHtmlEdit = class(TFrame)
    RzToolbar: TRzToolbar;
    ImageList: TImageList;
    BtnBold: TRzToolButton;
    BtnItalic: TRzToolButton;
    BtnUnderline: TRzToolButton;
    BtnFontColor: TRzToolButton;
    BtnLeftJustify: TRzToolButton;
    BtnCenterJustify: TRzToolButton;
    BtnRightJustify: TRzToolButton;
    BtnInsertImage: TRzToolButton;
    BtnUndo: TRzToolButton;
    BtnRedo: TRzToolButton;
    RzSpacer4: TRzSpacer;
    RzSpacer7: TRzSpacer;
    RzFontComboBox: TRzFontComboBox;
    cbFontSize: TRzComboBox;
    RzSpacer8: TRzSpacer;
    BtnStrikeThrough: TRzToolButton;
    BtnSuperScript: TRzToolButton;
    BtnSubScript: TRzToolButton;
    BtnOutdent: TRzToolButton;
    BtnIndent: TRzToolButton;
    BtnInsertParagraph: TRzToolButton;
    BtnCreateLink: TRzToolButton;
    WebBrowser: TWebBrowser;
    btnRefresh: TRzToolButton;
    procedure BtnUnderlineClick(Sender: TObject);
    procedure BtnUndoClick(Sender: TObject);
    procedure BtnRedoClick(Sender: TObject);
    procedure BtnLeftJustifyClick(Sender: TObject);
    procedure BtnRightJustifyClick(Sender: TObject);
    procedure BtnInsertImageClick(Sender: TObject);
    procedure BtnFontColorClick(Sender: TObject);
    procedure BtnBoldClick(Sender: TObject);
    procedure BtnItalicClick(Sender: TObject);
    procedure BtnStrikeThroughClick(Sender: TObject);
    procedure RzFontComboBoxCloseUp(Sender: TObject);
    procedure cbFontSizeCloseUp(Sender: TObject);
    procedure BtnCenterJustifyClick(Sender: TObject);
    procedure BtnSuperScriptClick(Sender: TObject);
    procedure BtnSubScriptClick(Sender: TObject);
    procedure BtnOutdentClick(Sender: TObject);
    procedure BtnIndentClick(Sender: TObject);
    procedure BtnInsertParagraphClick(Sender: TObject);
    procedure BtnCreateLinkClick(Sender: TObject);
    procedure btnRefreshClick(Sender: TObject);
  private
    { Private declarations }
    HTMLDocument2: IHTMLDocument2;
    //WebBrowser上回车等按键事件处理
    procedure MessageHandler(var Msg: TMsg; var Handled: Boolean);
    function GetHTML: WideString;
    procedure SetHTML(const Value: WideString);
    function GetText: WideString;
    procedure SetText(const Value: WideString);
    function GetSource: string;
  public
    { Public declarations }
    //初始化操作，将WebBrowser置为可编辑状态， 在窗体OnCreate时执行
    procedure Init;
    //检查图片容量是否超过指定大小
    function CheckImgSize(Size: Int64): Boolean; overload;
    //检查图片容量是否超过指定大小
    function CheckImgSize: Boolean; overload;    property HTML: WideString read GetHTML write SetHTML;
    property Text: WideString read GetText write SetText;
    property Source: string read GetSource;
    //获得将图片地址替换掉的HTML，地址替换成C:\Exam\SubjectID_PictureNo.jpg
    function GetHTML_(ID: string): WideString;
  end;implementationuses Winapi.ActiveX, unt_FileProc, unt_OtherProc, unt_StringProc;{$R *.dfm}procedure TfraHtmlEdit.BtnBoldClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('Bold', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnCenterJustifyClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('JustifyCenter', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnCreateLinkClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('CreateLink', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnFontColorClick(Sender: TObject);
  function ColorToString(Color: TColor): string;
  var
    cl: Cardinal;
  begin
    cl := ColorToRGB(Color);
    Result := '#' + IntToHex(Byte(cl), 2) + IntToHex(Byte(cl shr 8), 2) + IntToHex(Byte(cl shr 16), 2);
  end;
var
  ColorDialog: TColorDialog;
begin
  ColorDialog := TColorDialog.Create(Self);
  try
    if ColorDialog.Execute(Handle) then
    begin
      with (WebBrowser.Document as IHTMLDocument2) do
      begin
        execCommand('ForeColor', False, ColorToString(ColorDialog.Color));
        webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
      end;
    end;
  finally
    ColorDialog.Free;
  end;
end;procedure TfraHtmlEdit.BtnIndentClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('Indent', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnInsertImageClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('InsertImage', True, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnInsertParagraphClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('InsertParagraph', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnItalicClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('Italic', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnLeftJustifyClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('JustifyLeft', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnRedoClick(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_REDO, OLECMDEXECOPT_DODEFAULT);
end;procedure TfraHtmlEdit.btnRefreshClick(Sender: TObject);
var
  SourceHTML, ShapeStr, StyleStr, ImgStr, SrcStr, Str: string;
  i, j: Integer;
begin
{<v:shape id=_x0000_i1025
  style="HEIGHT: 33.75pt;WIDTH: 1in" o:ole="" type="#_x0000_t75"><v:imagedata o:title=""
  src="file:///C:\Users\ADMINI~1\AppData\Local\Temp\msohtml1\01\clip_image001.wmz">
  </v:imagedata></v:shape>}
//替换为如下：
{<img style="HEIGHT: 33.75pt;WIDTH: 1in" src="c:/clip_image001.wmz"}
  SourceHTML := HTML;
  while Pos('<v:shape ', SourceHTML) > 0 do
  begin
    i := Pos('<v:shape ', SourceHTML);
    j := Pos('</v:shape>', SourceHTML)+10;
    ShapeStr := Copy(SourceHTML, i, j-i);//将shape截出来
    Str := Copy(ShapeStr, Pos('style=', ShapeStr)+7, Length(ShapeStr));
    StyleStr := Copy(Str, 0, Pos('"', Str)-1);//将shape中的style截出来
    Str := Copy(ShapeStr, Pos('src=', ShapeStr)+13, Length(ShapeStr));
    SrcStr := Copy(Str, 0, Pos('"', Str)-1);
    Str := ExtractFileNameWithoutExt(SrcStr);
    SrcStr := ExtractFilePath(SrcStr)
            + LeftStr(Str, Length(Str)-3)+RightStr('00'+IntToStr(StrToInt(RightStr(Str, 3))+1),3)
            + '.gif';
    CopyFile_(SrcStr, ExtractFilePath(ParamStr(0))+'Temp\'+GetGuidValue+ExtractFileExt(SrcStr));
    SrcStr := ExtractFilePath(ParamStr(0))+'Temp\'+GetGuidValue+ExtractFileExt(SrcStr);
    ImgStr := '<img style="'+StyleStr+'" src="'+SrcStr+'"/>';
    MsgDlg(ImgStr);
    SourceHTML := StringReplace(SourceHTML, ShapeStr, ImgStr, [rfReplaceAll]);
    MsgDlg(SourceHTML);
  {
  int start = html.IndexOf("<v:shape ");
  int end = html.IndexOf("<:shape>") + 10;
  string shapeImageStr = html.Substring(start, end - start);
  string styleStart = shapeImageStr.Substring(shapeImageStr.IndexOf("style=\"") + 7);
  string style = styleStart.Substring(0, styleStart.IndexOf("\""));//提取style属性值
  string srcStart = shapeImageStr.Substring(shapeImageStr.IndexOf("src=\"") + 5);
  string src = srcStart.Substring(0, srcStart.IndexOf("\""));//提取src属性值
  src = Path.GetFullPath(src.Replace("%20", " ").Replace("file:///", ""));
  //把剪贴板中图片复制到临时文件夹temp下，防止剪贴板重复粘贴出现后面的图片一直显示为第一次粘贴的图片
  string newImageFileName = tempFilePath+Guid.NewGuid().ToString("N") + Path.GetExtension(src);
  File.Copy(src, newImageFileName);  //拼接图片标签,(使用新图片路径)
  string imageStr = "<img style=\"" + style + "\" src=\"" + newImageFileName + "\"/>";
  //替换字符串
  html = html.Replace(shapeImageStr, imageStr);
  }
  end;
  HTML := SourceHTML;
end;

Answer 2

procedure TfraHtmlEdit.BtnRightJustifyClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('JustifyRight', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnUnderlineClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('Underline', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnUndoClick(Sender: TObject);
begin
  WebBrowser.ExecWB(OLECMDID_UNDO, OLECMDEXECOPT_DODEFAULT);
end;procedure TfraHtmlEdit.cbFontSizeCloseUp(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('FontSize', False, cbFontSize.ItemIndex + 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;function TfraHtmlEdit.CheckImgSize: Boolean;
begin
  Result := CheckImgSize(200*1024);
  if not Result then
  begin
    MsgDlg('图片容量太大，不能超过200k，请压缩图片后再继续保存操作', '提示', MB_OK + MB_ICONINFORMATION);
    WebBrowser.SetFocus;
  end;
end;function TfraHtmlEdit.CheckImgSize(Size: Int64): Boolean;
var
  i: Integer;
  FileName: string;
begin
  Result := True;
  for i := 0 to WebBrowser.OleObject.document.images.length - 1 do
  begin
    FileName := WebBrowser.OleObject.document.images.item(i).href;
    FileName := StringReplace(FileName, 'file:///', '', [rfReplaceAll]);
    FileName := StringReplace(FileName, '/', '\', [rfReplaceAll]);
    FileName := StringReplace(FileName, '%20', ' ', [rfReplaceAll]);
    if GetFileSizes(FileName) > Size then
    begin
      Result := False;
      Break;
    end;
  end;
end;function TfraHtmlEdit.GetHTML: WideString;
begin
  Result := (WebBrowser.Document as IHTMLDocument2).body.innerHTML;
end;function TfraHtmlEdit.GetHTML_(ID: string): WideString;
var
  i: Integer;
  FileName: string;
  str: WideString;
begin
  str := HTML;
  for i := 0 to WebBrowser.OleObject.document.images.length - 1 do
  begin//注意：这有时候地址会替换不过来
    FileName := StringReplace(WebBrowser.OleObject.document.images.item(i).href, 'file:///', '', [rfReplaceAll]);
    FileName := StringReplace(FileName, '/', '\', [rfReplaceAll]);
    FileName := StringReplace(FileName, '%20', ' ', [rfReplaceAll]);
    str := StringReplace(str, FileName, 'C:\Temp\'+ID+'_'+IntToStr(i)+ExtractFileExt(FileName), [rfReplaceAll]);
  end;
  Result := str;
end;function TfraHtmlEdit.GetSource: string;
var
  i: Integer;
  Disp: IDispatch;
  Element: IHTMLElement;
begin
  for i := 0 to (WebBrowser.Document as IHTMLDocument2).all.length -1 do
  begin
    Disp := (WebBrowser.Document as IHTMLDocument2).all.item(i, 0);
    if Disp <> nil then
    begin
      Disp.QueryInterface(IID_IHTMLElement, Element);
      if Element <> nil then
        if SameText(Element.tagName, 'html') then
        begin
          Result := Element.outerHTML;
          Break;
        end;
    end;
  end;
end;function TfraHtmlEdit.GetText: WideString;
begin
  Result := (WebBrowser.Document as IHTMLDocument2).body.innerText;//HTMLDocument2.body.innerText;
end;procedure TfraHtmlEdit.Init;
begin
  Application.OnMessage := MessageHandler;
  WebBrowser.Navigate('about:blank');
  while WebBrowser.Busy do
    Application.ProcessMessages;
  HTMLDocument2 := WebBrowser.Document as IHTMLDocument2;
  if not SameText(HTMLDocument2.designMode, 'on') then
    HTMLDocument2.designMode := 'on';
end;procedure TfraHtmlEdit.MessageHandler(var Msg: TMsg; var Handled: Boolean);
const
  StdKeys = [VK_TAB, VK_RETURN]; { 标准键 }
  ExtKeys = [VK_Delete, VK_BACK, VK_LEFT, VK_RIGHT]; { 扩展键 }
  fExtended = $01000000; { 扩展键标志 }
begin
  Handled := False;
  with Msg do
  if ((Message >= WM_KEYFIRST)
  and (Message <= WM_KEYLAST))
  and ((wParam in StdKeys) or (GetKeyState(VK_CONTROL) < 0) or (wParam in ExtKeys)
  and ((lParam and fExtended) = fExtended)) then
  try
    if IsChild(webbrowser.Handle, hWnd) then
    { 处理所有的浏览器相关消息 }
    begin
    with (Webbrowser.Application as IOleInPlaceActiveObject) do
      Handled := TranslateAccelerator(Msg) = S_OK;
    if not Handled then
    begin
      Handled := True;
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
  except
  end;
end;procedure TfraHtmlEdit.RzFontComboBoxCloseUp(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('FontName', False, RzFontComboBox.FontName);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnOutdentClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('Outdent', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnSuperScriptClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('SuperScript', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnSubScriptClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('SubScript', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.BtnStrikeThroughClick(Sender: TObject);
begin
  with (WebBrowser.Document as IHTMLDocument2) do
  begin
    execCommand('StrikeThrough', False, 1);
    webbrowser.ExecWB(OLECMDID_SAVE, OLECMDEXECOPT_DONTPROMPTUSER);
  end;
end;procedure TfraHtmlEdit.SetHTML(const Value: WideString);
begin
  Application.ProcessMessages;
  HTMLDocument2.body.innerHTML := Value;
end;procedure TfraHtmlEdit.SetText(const Value: WideString);
begin
  Application.ProcessMessages;
  HTMLDocument2.body.innerText := Value;
end;initialization 　　　
   OleInitialize(nil);
finalization 　　　
try 　　　　
   OleUninitialize; 　　　
exceptend;end.

Answer 3

我这里已经用了好多年了 基本上相对比较稳定了
但是html编辑毕竟不如word 所以我最近在考虑换成word 
也在这里发帖请教大家
http://bbs.csdn.net/topics/390813483