Email服务器

开发平台：
Delphi

uHtmlEdit.pas：源码内容
							{*******************************************************}
{                                                       }
{       作者: 隐神                                      }
{                                                       }
{       日期: 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,OleServer;
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 清除当前选中区的选中状态。
  }
  // 选择色彩对话窗
  TUnorderedListType=(ultDisc,ultCricle,ultSquare);
  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 InsertObject(const OuterHtml: WideString);
    procedure SetOnColorDialog(const Value: TOnColorDialog);
  protected
    // InsertImage 插入图片 只留一个接口, 图片名必须由外部提供
    procedure InsertImage; overload; virtual;
  public
    SelectedTable: IHTMLElement;
    constructor Create(AHTMLDocument: IHTMLDocument2);
    // BackColor 突出显示
    procedure BackColor; overload;
    //---------------------------added by wp---------------------------------
    procedure InsertH1(InnerText:string); //插入标题
    procedure InsertH2(InnerText:string);
    procedure InsertH3(InnerText:string);
    procedure InsertH4(InnerText:string);
    procedure InsertH5(InnerText:string);
    
    procedure InsertHr;      //插入水平线
    procedure InsertOrderedList(List:TStrings;TypeChar:Char); overload;//插入列表
     //插入不排序的列表，UnorderedListType指出每项前面的符号
    procedure InsertUnorderedList(List:TStrings;UnorderedListType:TUnorderedListType);overload;
    //插入自定义的列表 .每个项目的缩进以前面的tab建个数决定。没有tab建不缩进，有一个tab建缩进一层。
    //(只有缩进1层和没有缩进2中情况。否则忽略改行)。
    procedure InsertDefinedList(List:TStrings );
    procedure InsertButton(Caption:string);
    procedure InsertLabel(Caption:string);
    procedure InsertEdit(DefaultText:string='');
    //----------------------------------------------------------------------
    // 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;  overload;
    // inserttable 插入表格
    procedure InsertTable(const Col: Integer = 2; const Row: Integer = 2;Borlder:integer=1);
    // 切消项目符号
    procedure InsertUnOrderedList;  overload;
    function IsTableSelected: 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;
  THistoryFile = class
  private
    FFilename: TFilename;
    //FFileStream:TFileStream;
  protected
    class procedure Open;
    constructor CreateInstance;
    class function AccessInstance(Request: Integer): THistoryFile;
  public
    procedure Write(const AText: string); 
    constructor Create;
    class function Instance: THistoryFile;
    class procedure ReleaseInstance;
  //published
    //property Filename: TFilename read FFilename write SetFilename;
  end;
  THtmlInspector=class(TInternetExplorer) ;
  TOnClipboardEvent = procedure(Sender: TObject; AClipboard: TClipboard) of
    object;
  TOnKeyHyperlink = procedure(Sender: TObject; var vHyperlink: string) of
    object;
  THTMLDocumentEvent=procedure(Sender:TObject; const   pEvtObj:
                      IHTMLEventObj) of object;
  THtmlEdit = class(TWebBrowser)
  private
    FEdit: TEditCommander;
    FFont: TFont;
    //FHistory: THistoryFile;
    FHTMLDocument: IHTMLDocument2;
    FImageFolder: string;
    FOnKeyHyperlink: TOnKeyHyperlink;
    FOnPaste: TOnClipboardEvent;
    FReadOnly: Boolean;
    FCharSet: string;
    //FOleInPlaceActiveObject:IOleInPlaceActiveObject;
 
    FoControlRange: IHTMLControlRange;
    FOnDataSetChanged:THTMLDocumentEvent;
    FInspector:THtmlInspector;
    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);
    function GetModified: boolean;
  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 SearchText;                  //查找  added by wp
    //procedure SetCharSet(ACharSet: String);  overload;  //设置编码     added by wp
    //插入内容
    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;
    function CanFocus: Boolean; override;
  published
    property OnDataSetChanged:THTMLDocumentEvent read FOnDataSetChanged write FOnDataSetChanged ;//dispid -2147412072;
    // 只读属性
    property ReadOnly: Boolean read FReadOnly write SetReadOnly;
    
    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;
    property Modified:boolean read GetModified;
  end;
procedure Register;
implementation
uses uMD5;
procedure Register;
begin
  RegisterComponents('HtmlEdit', [THtmlEdit]);
  //RegisterComponents('HtmlEdit', [THistoryFile]);
end;
function GetTempDir: string;
var
  TmpDir: array[0..255] of Char;
begin
  GetTempPath(255, @TmpDir);
  Result := StrPas(TmpDir);
  TmpDir := '';
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;Borlder:integer=1);
var
  ColCnt, RowCnt: Integer;
  sTable: string;
begin
  //sTable是表格的Html代码
  sTable := '<TABLE border='+inttostr(Borlder)+' >';
  for RowCnt := 1 to Row do
  begin
    sTable := sTable + '<TR>';
    for ColCnt := 1 to Col do
      sTable := sTable + '<TD>&nbsp;&nbsp;&nbsp;&nbsp;</TD>';
    sTable := sTable + '</TR>';
  end;
  sTable := sTable + '</TABLE>';
  //插入Html表格
  InsertHTML(sTable);
  SetFocus;
end; { TEditCommander.InsertTable }
procedure TEditCommander.InsertUnOrderedList;
begin
  Format('InsertUnOrderedList');
end; { TEditCommander.InsertUnOrderedList }
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 }
var
  FFileStream:TFileStream=nil;
  Active:Boolean=false;
class function THistoryFile.AccessInstance(Request: Integer): THistoryFile;
{$J+}
  const FInstance: THistoryFile = nil;
{$J-}
begin
  case Request of
    0 : ;
    1 : if not Assigned(FInstance) then FInstance := CreateInstance;
    2 : FInstance := nil;
  else
    raise Exception.CreateFmt('Illegal request %d in AccessInstance', [Request]);
  end;
  Result := FInstance;
end;
constructor THistoryFile.Create;
begin
  inherited Create;
  raise Exception.CreateFmt('Access class %s through Instance only', [ClassName]);
end;
constructor THistoryFile.CreateInstance;
begin
  inherited Create;
  FFilename:=IncludeTrailingPathDelimiter(GetTempDir)+ExtractFileName(Application.ExeName)+'.his';
  Open;
  Active:=true;
end;
class function THistoryFile.Instance: THistoryFile;
begin
  Result := AccessInstance(1);
end;
class procedure THistoryFile.Open;
begin
  if not FileExists(IncludeTrailingPathDelimiter(GetTempDir)+ExtractFileName(Application.ExeName)+'.his') then
  begin
    FFileStream := TFileStream.Create(IncludeTrailingPathDelimiter(GetTempDir)+ExtractFileName(Application.ExeName)+'.his', fmCreate or fmShareDenyWrite);
  end
  else
  begin
    FFileStream := TFileStream.Create(IncludeTrailingPathDelimiter(GetTempDir)+ExtractFileName(Application.ExeName)+'.his', 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 }
class procedure THistoryFile.ReleaseInstance;
begin
  AccessInstance(0).Free;
  Active:=false;
  FreeAndNil(FFileStream);
end;
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);
var
  doc:IHtmlDocument3;
begin
  inherited Create(AOwner);
  Self.Navigate('about:blank');
  FHTMLDocument := IHTMLDocument2(Self.Document);
  //编辑指令
  FEdit := TEditCommander.Create(FHTMLDocument);
  //缺省是系统临时文件夹
  ImageFolder := GetTempDir;
  ReadOnly := False;
  CharSet := 'gb2312';
  //here added by wp 
  //  FHtmlFont := THtmlFont.Create(HTMLDocument);
  FoControlRange:=nil;
  //FInspector:=THtmlInspector.Create(nil) ;
  //FInspector.ConnectKind:=ckRunningInstance;
  //FInspector.ConnectTo(self as IWebBrowser2);
  if self.Document.QueryInterface(IHtmlDocument3,Doc)=S_FALSE then
    raise Exception.Create('IHtmlDocument3 interface NOT Implement! ');
  if not doc.attachEvent('ondatasetchanged',self) then
    raise Exception.Create('attachEvent failure! ');
  //FHistory:=THistoryFile.Instance;
  //FOldOnMessage:=Forms.Application.OnMessage;
 // Forms.Application.OnMessage := Self.OnMessage;
end; { THtmlEdit.Create }
destructor THtmlEdit.Destroy;
begin
  //FInspector.disconnect;
  //FInspector.free;
  FreeAndNil(FEdit);
  //self.FHistory.ReleaseInstance;
  //self.FHistory:=nil;
  //Forms.Application.OnMessage:=Self.FOldOnMessage;
  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); //added by wp
//const
//  DialogKeys: set of Byte = [VK_LEFT, VK_RIGHT, VK_BACK, VK_UP, VK_DOWN,
//    $30..$39, $41..42, $44..$55, $57, $59..$5A];
//var
// { p: tpoint;
//  TheName: array[0..255] of char;   }
//  iOIPAO: IOleInPlaceActiveObject;
//  Dispatch: IDispatch;
//
//begin
//  Handled := (IsDialogMessage(self.Handle, Msg) = True);
//
//  if (not Handled )or( Busy) then  Exit;
//
//  if FOleInPlaceActiveObject = nil then
//  begin
//    Dispatch := Self.Application;
//    if Dispatch <> nil then
//    begin
//      Dispatch.QueryInterface(IOleInPlaceActiveObject, iOIPAO);
//      if iOIPAO <> nil then
//        FOleInPlaceActiveObject := iOIPAO;
//    end;
//  end
//  else
//  begin
//    if ((Msg.message = WM_KEYDOWN) or (Msg.message = WM_KEYUP)) then
//    begin
//      case Msg.wParam of
//        VK_DELETE,VK_BACK,VK_CLEAR : if FoControlRange<>nil then FoControlRange.remove(0) ;
//
//      else;
//      end;
//      FoControlRange:=nil;
//    end
//    else if (Msg.message =Messages.WM_MBUTTONDBLCLK) then
//    begin
//      FoControlRange:=nil;
//      if UpperCase(FHTMLDocument.selection.type_) = 'CONTROL' then
//      begin
//
//        if (UpperCase((FoControlRange.item(0) as IHTMLElement).tagName) = 'INPUT') or
//                  (UpperCase((FoControlRange.item(0) as IHTMLElement).tagName)='LABEL')  then
//        begin
//          FoControlRange := (FHTMLDocument.selection.createRange as IHTMLControlRange);
//          FoControlRange.select;
//          //FSelectedItem := ((FHTMLDocument.selection.createRange as
//          //  IHTMLControlRange).item(0)) as IHTMLElement;
//        end;
//      end    // nothing - do not pass on the DialogKeys
//    end
//    else
//    begin
//      FoControlRange:=nil;
//      FOleInPlaceActiveObject.TranslateAccelerator(Msg);
//    end;
//  end;
//
//  //本函数放在 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.SetCharSet(ACharSet:String);
var
　RefreshLevel: OleVariant;
Begin
　IHTMLDocument2(Self.Document).Set_CharSet(ACharSet);
　RefreshLevel :=7;　　　　　　　　　　　　　　//这个7应该从注册表来，帮助有Bug。
　Self.Refresh2(RefreshLevel);
End; }
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;
procedure THtmlEdit.SearchText;
const
  CLSID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
  CmdTarget: IOleCommandTarget;
begin
  try
    Self.Document.QueryInterface(IOleCommandTarget, CmdTarget);
    if CmdTarget <> nil then
    try
      CmdTarget.Exec(@CLSID_WebBrowser, 1, 0, EmptyParam, EmptyParam);
    finally
      CmdTarget._Release;
    end;
  except
  end;
end;
procedure TEditCommander.InsertH1(InnerText: string);
begin
  InsertHTML('<H1>'+InnerText+'</H1>');
  SetFocus;
end;
procedure TEditCommander.InsertH2(InnerText: string);
begin
  InsertHTML('<H2>'+InnerText+'</H2>');
  SetFocus;
end;
procedure TEditCommander.InsertH3;
begin
  InsertHTML('<H3>'+InnerText+'</H3>');
  SetFocus;
end;
procedure TEditCommander.InsertHr;
begin
  InsertHTML('<Hr/>');
  SetFocus;
end;
procedure TEditCommander.InsertDefinedList(List: TStrings);
var
  I,Count:Integer;
  S,sTemp:string;
  
  function TabCount(var S:String):Integer;
  begin
    Result:=0;
    if Length(S)=0 then Exit;
    while (Length(S)>0) and (S[1]=#9) do
    begin
       Inc(Result);
       S:=Copy(S,2,MAXWORD);
    end;
  end;
begin
  {
  <dl>
<dt>野生动物</dt>
<dd>所有非经人工饲养而生活于自然环境下的各种动物。</dd>
<dt>宠物</dt>
<dd>指猫、狗以及其它供玩赏、陪伴、领养、饲养的动物，又称作同伴动物。</dd>
</dl>
  }
  S:='<dl>';
  for I:=0 to List.Count-1 do
  begin
    sTemp:=List[I];
    Count:=TabCount(sTemp);
    if  Count=0 then
      S:=S+'<dt>'+sTemp+'</dt>'
    else if Count=1 then
      S:=S+'<dd>'+sTemp+'</dd>'
    else
      raise Exception.Create(SysUtils.Format('最多只有缩进一层的情况出现！而在第%D行发现了%D个Tab建。',[I,Count]));
    S:=S+'</dl>';
  end;
  InsertHTML(S);
  SetFocus;
end;
procedure TEditCommander.InsertOrderedList(List: TStrings; TypeChar: Char);
var
  S:string;
  I:Integer;
begin
  {
  <ol type="A">
  <li>布啦布啦之网页课程</li>
  <li>布啦布啦之网页代码</li>
  <li>布啦布啦之魔兽世界</li>
  </ol>
  }
  S:='<ol type="'+TypeChar+'"> ';
  for I:=0 to List.Count-1 do
     S:='<li>'+S+List[I]+'</li>';
  S:=S+'</ol>';
  InsertHTML(S);
  SetFocus;
end;
procedure TEditCommander.InsertUnorderedList(List: TStrings;
  UnorderedListType: TUnorderedListType);
  var
  S,Typechar:string;
  I:Integer;
begin
  {
  <ul type="square">
<li>布啦布啦之网页课程</li>
<li>布啦布啦之网页代码</li>
<li>布啦布啦之魔兽世界</li>
</ul>
  }
  case UnorderedListType of
    ultDisc: Typechar :='Disc';
    ultCricle: Typechar:='Cricle';
    ultSquare: Typechar:='Square';
  else ;
  end;
  S:='<ul type="'+TypeChar+'"> ';
  for I:=0 to List.Count-1 do
     S:='<li>'+S+List[I]+'</li>';
  S:=S+'</ul>';
  InsertHTML(S);
  SetFocus;
end;
procedure TEditCommander.InsertH4(InnerText: string);
begin
  InsertHTML('<H4>'+InnerText+'</H4>');
  SetFocus;
end;
procedure TEditCommander.InsertH5(InnerText: string);
begin
  InsertHTML('<H5>'+InnerText+'</H5>');
  SetFocus;
end;
procedure TEditCommander.InsertButton(Caption: string);
begin
  InsertHtml('<form><input type="button" value="'+Caption+'" /></Form>');
  SetFocus;
end;
procedure TEditCommander.InsertEdit(DefaultText: string);
begin
  InsertHtml('<form><input type="text" value="'+DefaultText+'" /></Form>');
  SetFocus;
end;
procedure TEditCommander.InsertLabel(Caption: string);
begin
  InsertHtml('<label >'+caption+'</label>');
  SetFocus;
end;
{procedure TEditCommander.InsertObject(const OuterHtml: WideString);
var
  Element:IHTMLDoMNode;
begin
  if Self.FHTMLDocument<>nil then
  begin                            
    Element:=IHTMLDoMNode(FHTMLDocument.createElement(''));
    IHTMLDOMNode(FHTMLDocument.body).appendChild(Element) ;
    IHTMLElement(Element).outerHTML:=OuterHtml;
  end;
end;  }
function THtmlEdit.GetModified: boolean;
begin
  Result:= self.FHTMLDocument.lastModified<>'';
end;
initialization
  OleInitialize(nil);
finalization
  try
    OleUninitialize;
  except
  end;
end.

						