TEditWebBrowser 组件
超强的Edit功能，完全替代TRichEdit组件，可以更方便的插入图片和表格。
unit EditWebBrowser;
//////////
// 制作：xcoming
// 版本：2005-8-30
// 联系：xcoming@21cn.com
//////////
interface
uses
SysUtils, Classes, Controls, OleCtrls, SHDocVw,Consts,
Messages,Forms,windows,ActiveX,typinfo,MSHTML;
const
IID_IOleCommandTarget:TGUID='{B722BCCB-4E68-101B-A2BC-00AA00404770}';
type
TMouseDownEvent=procedure(Sender:Tobject;Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
TMouseUpEvent=procedure(Sender:Tobject;Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
TMouseMoveEvent=procedure(Sender:Tobject;Shift:TShiftState;x,y:integer) of object;
TEnterEvent=procedure(Sender:Tobject) of object;
TExitEvent=procedure(Sender:Tobject) of object;
TDblClickEvent=procedure(Sender:Tobject;Button:TMouseButton;Shift:TShiftState;x,y:integer) of object;
TKeyDownEvent=procedure(Sender:Tobject;Shift:TShiftState;Key:word) of object;
TKeyUpEvent=procedure(Sender:Tobject;Shift:TShiftState;Key:word) of object;
TEditWebBrowser = class(TWebBrowser)
private
{ Private declarations }
FParentWinControl:TWinControl;
FApplication:TApplication;
FOnMouseDown:TMouseDownEvent;
FOnMouseUp:TMouseUpEvent;
FOnMouseMove:TMouseMoveEvent;
FOnEnter:TEnterEvent;
FOnExit:TExitEvent;
FOnDblClick:TDblClickEvent;
FOnKeyDown:TKeyDownEvent;
FOnKeyUp:TKeyUpEvent;
FFocused:boolean;
FisShowSelfPopupMenu:boolean;
FWantReturns:boolean;
FVisible:boolean;
FShiftFoceed,FCtrlFoceed:boolean;
FReadOnly:boolean;
FScrollbar:boolean;
procedure OnMyMessage(var Msg:TMsg;var Handled:Boolean);
function GetPoint(C:TComponent;p:TPoint):TPoint;
procedure DoMouseDown(Button:TMouseButton;Shift:TShiftState;x,y:integer);
procedure DoMouseUp(Button:TMouseButton;Shift:TShiftState;x,y:integer);
procedure DoMouseMove(Shift:TShiftState;x,y:integer);
procedure DoDblClick(Button:TMouseButton;Shift:TShiftState;x,y:integer);
procedure DoKeyDown(Shift:TShiftState;Key:word);
procedure DoKeyUp(Shift:TShiftState;Key:word);
function GetInnerHTML:string;
function GetInnerText:string;
procedure SetisShowSelfPopupMenu(v:boolean);
procedure SetWantReturns(v:boolean);
procedure SetReadOnly(v:boolean);
function GetScrollTop:integer;
function GetScrollHeight:integer;
function GetScrollLeft:integer;
function GetScrollWidth:integer;
function GetDocument:IHTMLDocument2;
function GetWindow:IHTMLWindow2;
function GetDocCMD:IOleCommandTarget;
procedure SetScrollbar(v:boolean);
function GetSelText():string;
procedure SetSelText(s:string);
function GetSelHTML():string;
procedure SetSelHTML(s:string);
procedure SetVisible(v:boolean);
procedure DoEnter;
procedure DoExit;
protected
public
{ Public declarations }
constructor Create(Owner:TComponent);override;
destructor Destroy;override;
property Focused:boolean read FFocused;
property InnerHTML:String read GetInnerHTML;
property InnerText:String read GetInnerText;
property ScrollTop:integer read GetScrollTop;
property ScrollHeight:integer read GetScrollHeight;
property ScrollLeft:integer read GetScrollLeft;
property ScrollWidth:integer read GetScrollWidth;
property Doc:IHTMLDocument2 read GetDocument;
property Win:IHTMLWindow2 read GetWindow;
property DocCMD:IOleCommandTarget read GetDocCMD;
property Scrollbar:boolean read FScrollbar write SetScrollbar;
property SelText:string read GetSelText write SetSelText;
property SelHTML:string read GetSelHTML write SetSelHTML;
procedure SetFocus;
procedure WriteHTML(HTML:string);
procedure AppendHTML(HTML:string);
procedure Clear;
procedure Print(isPrintView:boolean=true);
procedure PrintPageSetup;
procedure Copy;
procedure Cut;
procedure Paste;
procedure SelectAll;
procedure SaveAs(FileName:string='blank.htm');
procedure ScrollTo(x,y:integer);
procedure SetMargin(top,bottom,left,right:integer);
procedure SetSelection(Start,Length:integer);
published
{ Published declarations }
property OnMouseDown:TMouseDownEvent read FOnMouseDown write FOnMouseDown;
property OnMouseUp:TMouseUpEvent read FOnMouseUp write FOnMouseUp;
property OnMouseMove:TMouseMoveEvent read FOnMouseMove write FOnMouseMove;
property OnEnter:TEnterEvent read FOnEnter write FOnEnter;
property OnExit:TExitEvent read FOnExit write FOnExit;
property OnDblClick:TDblClickEvent read FOnDblClick write FOnDblClick;
property OnKeyUp:TKeyUpEvent read FOnKeyUp write FOnKeyUp;
property OnKeyDown:TKeyDownEvent read FOnKeyDown write FOnKeyDown;
property isShowSelfPopupMenu:boolean read FisShowSelfPopupMenu write SetisShowSelfPopupMenu;
property WantReturns:boolean read FWantReturns write SetWantReturns;
property ReadOnly:boolean read FReadOnly write SetReadOnly;
property Visible:boolean read FVisible write SetVisible;
end;
procedure Register;
implementation
type TEditWebBrowsers=class(TComponent)
private
constructor Create(AOwner: TComponent); override;
destructor Destroy;override;
public
EditWebBrowsers:array of TEditWebBrowser;
procedure OnMyMessage(var Msg:TMsg;var Handled:Boolean);
end;
var EditWebBrowsers:TEditWebBrowsers=nil;
procedure TEditWebBrowsers.OnMyMessage(var Msg:TMsg;var Handled:Boolean);
var i:integer;
begin
try
for i:=0 to length(self.EditWebBrowsers) do
if self.EditWebBrowsers[i]<>nil then
if not self.EditWebBrowsers[i].OleObject.document.hasfocus then
if self.EditWebBrowsers[i].FFocused then begin
self.EditWebBrowsers[i].DoExit; break;
end;
except end;
try
for i:=0 to length(self.EditWebBrowsers) do
if self.EditWebBrowsers[i]<>nil then
if self.EditWebBrowsers[i].OleObject.document.hasfocus then
if not self.EditWebBrowsers[i].FFocused then begin
self.EditWebBrowsers[i].DoEnter; break;
end;
except end;
try
for i:=0 to length(self.EditWebBrowsers) do
if self.EditWebBrowsers[i]<>nil then
try self.EditWebBrowsers[i].OnMyMessage(Msg,Handled); except end;
except end;
end;
constructor TEditWebBrowsers.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
Application.OnMessage:=OnMyMessage;
end;
destructor TEditWebBrowsers.Destroy;
begin
Application.OnMessage:=nil;
end;
constructor TEditWebBrowser.Create(Owner:TComponent);
var i:integer; flag:boolean;
begin
inherited Create(Owner);
if not Assigned(self.Document) then self.Navigate('about:blank');
self.SetReadOnly(false);
FisShowSelfPopupMenu:=true;
self.SetWantReturns(true);
self.SetisShowSelfPopupMenu(false);
self.FScrollbar:=true;
self.FFocused:=false;
self.FVisible:=true;
flag:=false;
try
for i:=0 to length(EditWebBrowsers.EditWebBrowsers)-1 do
if EditWebBrowsers.EditWebBrowsers[i]=nil then begin
EditWebBrowsers.EditWebBrowsers[i]:=self;
flag:=true;break;
end;
except end;
if not flag then begin
setLength(EditWebBrowsers.EditWebBrowsers
,length(EditWebBrowsers.EditWebBrowsers)+1);
EditWebBrowsers.EditWebBrowsers
[length(EditWebBrowsers.EditWebBrowsers)-1]:=self;
end;
end;
procedure TEditWebBrowser.DoEnter;
begin
self.FFocused:=true;
TWinControl(self).SetFocus;
if self.Win<>nil then self.Win.focus;
if Assigned(FOnEnter) then FOnEnter(self);
end;
procedure TEditWebBrowser.DoExit;
begin
self.FFocused:=false;
if self.OleObject.document.hasfocus then
if self.Win<>nil then self.Win.blur;
if Assigned(FOnExit) then FOnExit(self);
end;
function TEditWebBrowser.GetDocument:IHTMLDocument2;
begin
result:=self.Document as IHTMLDocument2;
end;
function TEditWebBrowser.GetWindow:IHTMLWindow2;
var W:IHTMLWindow2;
begin
repeat W:=self.Doc.parentWindow;
until W<>nil; result:=W;
end;
function TEditWebBrowser.GetDocCMD:IOleCommandTarget;
var DCMD:IOleCommandTarget;
begin
repeat self.Doc.QueryInterface(IOleCommandTarget,DCMD);
until DCMD<>nil;
result:=DCMD;
end;
procedure TEditWebBrowser.SetReadOnly(v:boolean);
begin
self.FReadOnly:=v;
if self.FReadOnly then
self.Doc.designMode:='off'
else
self.Doc.designMode:='on';
end;
procedure TEditWebBrowser.SetMargin(top,bottom,left,right:integer);
begin
self.Doc.body.style.marginTop:=top;
self.Doc.body.style.marginBottom:=bottom;
self.Doc.body.style.marginLeft:=left;
self.Doc.body.style.marginRight:=right;
end;
procedure TEditWebBrowser.ScrollTo(x,y:integer);
begin
self.OleObject.document.parentwindow.scrollto(x,y);
end;
function TEditWebBrowser.GetScrollTop:integer;
begin
result:=self.OleObject.document.body.scrollTop;
end;
function TEditWebBrowser.GetScrollHeight:integer;
begin
result:=self.OleObject.document.body.scrollHeight;
end;
function TEditWebBrowser.GetScrollLeft:integer;
begin
result:=self.OleObject.document.body.scrollLeft;
end;
function TEditWebBrowser.GetScrollWidth:integer;
begin
result:=self.OleObject.document.body.scrollWidth;
end;
destructor TEditWebBrowser.Destroy;
var i:integer;
begin
try
for i:=0 to length(EditWebBrowsers.EditWebBrowsers)-1 do
if EditWebBrowsers.EditWebBrowsers[i]=self then begin
EditWebBrowsers.EditWebBrowsers[i]:=nil;
break;
end;
except end;
inherited Destroy;
end;
function TEditWebBrowser.GetInnerHTML:string;
begin
result:=self.OleObject.document.All.item.innerhtml;
end;
function TEditWebBrowser.GetInnerText:string;
begin
result:=self.OleObject.document.All.item.innerText;
end;
procedure TEditWebBrowser.WriteHTML(HTML:string);
begin
self.OleObject.document.close();
self.OleObject.document.clear();
self.OleObject.document.write(HTML);
end;
procedure TEditWebBrowser.Clear;
begin
self.OleObject.document.close();
self.OleObject.document.clear();
//本方法不能真正清除文档，最好是用：WriteHtml(' ')清除
end;
procedure TEditWebBrowser.SetScrollbar(v:boolean);
begin
self.FScrollbar:=v;
if v then self.Doc.body.style.overflow:='scroll'
else self.Doc.body.style.overflow:='hidden'
end;
procedure TEditWebBrowser.AppendHTML(HTML:string);
begin
self.OleObject.document.write(HTML);
end;
procedure TEditWebBrowser.SetFocus;
begin
{注：设定某一个TEditWebBrowser的焦点时，如果当前的焦点正在另
一个TEditWebBrowser上，则此时最好先使有焦点的TEditWebBrowser控件
失去焦点。例如：
EW1有焦点，要通过程序设置EW2的焦点，应该这样：
EW1.Win.blur;
EW2.SetFocus;
}
self.Win.focus;
end;
procedure TEditWebBrowser.Print(isPrintView:boolean=true);
begin
if isPrintView then
self.ExecWB(OLECMDID_PRINTPREVIEW,OLECMDEXECOPT_DODEFAULT)
else
self.ExecWB(OLECMDID_PRINT,OLECMDEXECOPT_DODEFAULT);
end;
procedure TEditWebBrowser.PrintPageSetup;
begin
self.ExecWB(OLECMDID_PAGESETUP,OLECMDEXECOPT_DODEFAULT);
end;
procedure TEditWebBrowser.Copy;
begin
self.ExecWB(OLECMDID_COPY,OLECMDEXECOPT_DODEFAULT);
end;
procedure TEditWebBrowser.Paste;
begin
self.ExecWB(OLECMDID_PASTE,OLECMDEXECOPT_DODEFAULT);
end;
procedure TEditWebBrowser.SelectAll;
begin
self.ExecWB(OLECMDID_SELECTALL,OLECMDEXECOPT_DODEFAULT);
end;
procedure TEditWebBrowser.Cut;
begin
self.ExecWB(OLECMDID_CUT,OLECMDEXECOPT_DODEFAULT);
end;
procedure TEditWebBrowser.SaveAs(FileName:string='blank.htm');
begin
self.Doc.execCommand('SaveAs',false,FileName);
end;
function TEditWebBrowser.GetPoint(C:TComponent;p:TPoint):TPoint;
var rsp:TPoint;
begin
if C.Owner is TForm then begin
rsp.X:=p.X-(C.Owner as TForm).Left;
rsp.Y:=p.Y-(C.Owner as TForm).Top;
rsp.X:=rsp.X-((C.Owner as TForm).Width-(C.Owner as TForm).ClientWidth) div 2;
rsp.Y:=rsp.Y-((C.Owner as TForm).Height-(C.Owner as TForm).ClientHeight);
result:=rsp;
end else begin
rsp.X:=p.X-GetOrdProp(C.Owner,'Left');
rsp.Y:=p.Y-GetOrdProp(C.Owner,'Top');
result:=self.GetPoint(C.Owner,rsp);
end;
end;
procedure TEditWebBrowser.OnMyMessage(var Msg:TMsg;var Handled:Boolean);
var p:TPoint;ShiftState:TShiftState;Key:word;
bKey:TKeyBoardState;
begin
//GetCursorPos(p);
p.X:=Msg.pt.X-self.Left; p.Y:=Msg.pt.Y-self.Top;
p:=self.GetPoint(self,p);
if (p.X>=0) and (p.X<=self.Width) and (p.Y>=0)
and (p.Y<=self.Height) then begin
if Msg.message=WM_RBUTTONDOWN then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
Handled:=not self.FisShowSelfPopupMenu;
DoMouseDown(mbRight,ShiftState,p.X,p.Y);
end else if Msg.message=WM_LBUTTONDOWN then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
DoMouseDown(mbLeft,ShiftState,p.X,p.Y);
end else if Msg.message=WM_RBUTTONUP then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
Handled:=not self.FisShowSelfPopupMenu;
DoMouseUp(mbRight,ShiftState,p.X,p.Y);
end else if Msg.message=WM_LBUTTONUP then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
DoMouseUp(mbLeft,ShiftState,p.X,p.Y);
end else if Msg.message=WM_MOUSEMOVE then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
DoMouseMove(ShiftState,p.X,p.Y);
end else if Msg.message=WM_LBUTTONDBLCLK then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
DoDblClick(mbLeft,ShiftState,p.X,p.Y);
end else if Msg.message=WM_RBUTTONDBLCLK then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
Handled:=not self.FisShowSelfPopupMenu;
DoDblClick(mbRight,ShiftState,p.X,p.Y);
end;
end;
if self.OleObject.document.hasfocus then begin
if Msg.message=WM_KEYDOWN then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
Key:=Msg.wParam;
if not self.FReadOnly then begin
if Key=13 then begin
if self.FWantReturns then begin
if not (ssShift in ShiftState) then begin
GetKeyboardState(bKey);
bKey[VK_Shift]:=not bKey[VK_Shift];
SetKeyboardState(bKey);
self.FShiftFoceed:=true;
end;
end else begin
if (ssCtrl in ShiftState) then begin
self.FCtrlFoceed:=true;
GetKeyboardState(bKey);
bKey[VK_CONTROL]:=not bKey[VK_CONTROL];
SetKeyboardState(bKey);
if not (ssShift in ShiftState) then begin
GetKeyboardState(bKey);
bKey[VK_Shift]:=not bKey[VK_Shift];
SetKeyboardState(bKey);
self.FShiftFoceed:=true;
end;
end else Msg.wParam:=0;
end;
end;
end;
DoKeyDown(ShiftState,Key);
end else if Msg.message=WM_KEYUP then begin
ShiftState:=KeyDataToShiftState(Msg.wParam);
Key:=Msg.wParam;
if not self.FReadOnly then begin
if Key=13 then begin
if self.FShiftFoceed then begin
GetKeyboardState(bKey);
bKey[VK_Shift]:=not bKey[VK_Shift];
SetKeyboardState(bKey);
Msg.wParam:=0;
self.FShiftFoceed:=false;
end;
end;
end;
if self.FCtrlFoceed then begin
Include(ShiftState,ssCtrl);
self.FCtrlFoceed:=false;
end;
DoKeyUp(ShiftState,Key);
end;
end;
//TranslateMessage(Msg);
//DispatchMessage(Msg);
end;
procedure TEditWebBrowser.DoMouseDown(Button:TMouseButton;Shift:TShiftState;x,y:integer);
begin
if Assigned(FOnMouseDown) then FOnMouseDown(self,Button,Shift,x,y);
end;
procedure TEditWebBrowser.DoMouseUp(Button:TMouseButton;Shift:TShiftState;x,y:integer);
begin
if Assigned(FOnMouseUp) then FOnMouseUp(self,Button,Shift,x,y);
end;
procedure TEditWebBrowser.DoMouseMove(Shift:TShiftState;x,y:integer);
begin
if Assigned(FOnMouseMove) then FOnMouseMove(self,Shift,x,y);
end;
procedure TEditWebBrowser.DoDblClick(Button:TMouseButton;Shift:TShiftState;x,y:integer);
begin
if Assigned(FOnDblClick) then FOnDblClick(self,Button,Shift,x,y);
end;
procedure TEditWebBrowser.DoKeyDown(Shift:TShiftState;Key:word);
begin
if Assigned(FOnKeyDown) then FOnKeyDown(self,Shift,Key);
end;
procedure TEditWebBrowser.DoKeyUp(Shift:TShiftState;Key:word);
begin
if Assigned(FOnKeyUp) then FOnKeyUp(self,Shift,Key);
end;
procedure TEditWebBrowser.SetisShowSelfPopupMenu(v:boolean);
begin
self.FisShowSelfPopupMenu:=v;
end;
procedure TEditWebBrowser.SetWantReturns(v:boolean);
begin
self.FWantReturns:=v;
end;
function TEditWebBrowser.GetSelText():string;
begin
result:=(self.Doc.selection.createRange as IHtmlTxtRange).text;
end;
procedure TEditWebBrowser.SetSelText(s:string);
begin
(self.Doc.selection.createRange as IHtmlTxtRange).text:=s;
end;
function TEditWebBrowser.GetSelHTML():string;
begin
result:=(self.Doc.selection.createRange as IHtmlTxtRange).htmlText;
end;
procedure TEditWebBrowser.SetSelHTML(s:string);
begin
(self.Doc.selection.createRange as IHtmlTxtRange).pasteHTML(s);
end;
procedure TEditWebBrowser.SetVisible(v:boolean);
begin
self.FVisible:=v;
TWinControl(self).Visible:=v;
end;
procedure TEditWebBrowser.SetSelection(Start,Length:integer);
var TextRange:IHtmlTxtRange;
begin
self.Doc.selection.empty;
TextRange:=self.Doc.selection.createRange as IHtmlTxtRange;
TextRange.collapse(true);
TextRange.moveEnd('character',Start+Length);
TextRange.moveStart('character',Start);
TextRange.select;
end;
procedure Register;
begin
RegisterComponents('Internet', [TEditWebBrowser]);
end;
initialization
try OleInitialize(nil); except end;
EditWebBrowsers:=TEditWebBrowsers.Create(application);
finalization
try OleUninitialize; except end;
end.
转自：http://www.2ccc.com/article.asp?articleid=2525
