Delphi 中TWebBrowser的扩展控件TExWebBrowser

参考：
http://blog.csdn.net/missmecn/article/details/2292758
主要扩展了3D界面、右键菜单、是否显示图片、是否支持JAVA等功能。

代码如下：

unit ExtWebBrowser;

interface

uses

Windows, SysUtils, Classes, Controls, OleCtrls, SHDocVw, ActiveX, Forms, URLMon;

type

TDocHostUIInfo = packed record

cbSize : ULONG;

dwFlags : DWORD;

dwDoubleClick : DWORD;

pchHostCss : polestr;

pchHostNS : polestr;

end;

pDocHostUIInfo = ^TDocHostUIInfo;

IDocHostUIHandler = interface(IUnknown)

['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}']

function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch):HRESULT; stdcall;

function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;

function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;

function HideUI: HRESULT; stdcall;

function UpdateUI: HRESULT; stdcall;

function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;

function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;

function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;

function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT; stdcall;

function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup:PGUID; const nCmdID: DWORD): HRESULT; stdcall;

function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD):HRESULT; stdcall;

function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall;

function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;

function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall;

function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall;

end;

ICustomDoc = interface (IUnknown)

['{3050F3F0-98B5-11CF-BB82-00AA00BDCE0B}']

function SetUIHandler (const pUIHandler : IDocHostUIHandler) : HRESULT; stdcall;

end;

TExWebBrowser = class;

TUIProperties = class (TPersistent)

private

fOwner : TExWebBrowser;

fEnableContextMenu: boolean;

fEnableScrollBars: boolean;

fFlatScrollBars: boolean;

fHas3DBorder: boolean;

fOpenLinksInNewWindow: boolean;

fEnableScripting: boolean;

fShowImages: boolean;

fShowActiveX: boolean;

fEnableDownloadActiveX: boolean;

fEnableJava: boolean;

public

constructor Create (AOwner : TExWebBrowser);

published

property EnableContextMenu : boolean read fEnableContextMenu write fEnableContextMenu;

property EnableScrollBars : boolean read fEnableScrollBars write fEnableScrollBars;

property FlatScrollBars : boolean read fFlatScrollBars write fFlatScrollBars;

property Has3DBorder : boolean read fHas3DBorder write fHas3DBorder;

property OpenLinksInNewWindow : boolean read fOpenLinksInNewWindow write fOpenLinksInNewWindow;

property EnableScripting : boolean read fEnableScripting write fEnableScripting;

property EnableJava : boolean read fEnableJava write fEnableJava;

property EnableDownloadActiveX : boolean read fEnableDownloadActiveX write fEnableDownloadActiveX;

property ShowImages : boolean read fShowImages write fShowImages default True;

property ShowActiveX : boolean read fShowActiveX write fShowActiveX default True;

end;

TExWebBrowser = class(TWebBrowser, IDocHostUIHandler, IDispatch)

private

fUIProperties : TUIProperties;

fURL : string;

fInternetSession : IInternetSession;

{ IDispatch }

function IDispatch.Invoke = Invoke;

function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;

{ IDocHostUIHandler }

function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch):HRESULT; stdcall;

function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;

function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;

function HideUI: HRESULT; stdcall;

function UpdateUI: HRESULT; stdcall;

function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;

function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;

function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;

function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT; stdcall;

function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup:PGUID; const nCmdID: DWORD): HRESULT; stdcall;

function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD):HRESULT; stdcall;

function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall;

function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;

function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall;

function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall;

function GetURL: string;

procedure SetURL(const Value: string);

protected

procedure Loaded; override;

public

constructor Create (AOwner : TComponent); override;

destructor Destroy; override;

procedure LoadFromString (const st : string);

procedure LoadFromStream (s : TStream; takeOwnership : boolean = false);

published

property UIProperties : TUIProperties read fUIProperties write fUIProperties;

property URL : string read GetURL write SetURL;

end;

implementation

uses ComObj;

const

DOCHOSTUIFLAG_DIALOG = $00000001;

DOCHOSTUIFLAG_DISABLE_HELP_MENU = $00000002;

DOCHOSTUIFLAG_NO3DBORDER = $00000004;

DOCHOSTUIFLAG_SCROLL_NO = $00000008;

DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = $00000010;

DOCHOSTUIFLAG_OPENNEWWIN = $00000020;

DOCHOSTUIFLAG_DISABLE_OFFSCREEN = $00000040;

DOCHOSTUIFLAG_FLAT_SCROLLBAR = $00000080;

DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = $00000100;

DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = $00000200;

DOCHOSTUIFLAG_OVERRIDEBEHAVIOURFACTORY = $00000400;

DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = $00000800;

DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = $00001000;

DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = $00002000;

DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = $00004000;

{ TExWebBrowser }

constructor TExWebBrowser.Create(AOwner: TComponent);

///var

// Factory : IClassFactory;

begin

inherited Create (AOwner);

fUIProperties := TUIProperties.Create (self);

OleCheck (CoInternetGetSession (0, fInternetSession, 0));

if fInternetSession <> Nil then

begin

// CoGetClassObject(Class_CIDMimeFilter, CLSCTX_SERVER, nil, IClassFactory, Factory);

// OleCheck (fInternetSession.RegisterMimeFilter(Factory, Class_CIDMimeFilter, 'cid'));

// OleCheck (fInternetSession.RegisterNameSpace(Factory, CLASS_CIDMIMEFilter, 'cid', 0, nil, 0))

end

end;

destructor TExWebBrowser.Destroy;

begin

fUIProperties.Free;

inherited;

end;

(*----------------------------------------------------------------------*

| TExWebBrowser.EnableModeless |

| |

| IE calls this to tell us that our dialogs should be modeless. |

*----------------------------------------------------------------------*)

function TExWebBrowser.EnableModeless(const fEnable: BOOL): HRESULT;

begin

result := S_OK;

end;

(*----------------------------------------------------------------------*

| TExWebBrowser.FilterDataObject |

| |

| IE calls this before putting data objects on the clipboard. It |

| allows us to replace them or set them to nil. |

| |

| The function returns S_FALSE meaning we didn't replace the object |

*----------------------------------------------------------------------*)

function TExWebBrowser.FilterDataObject(const pDO: IDataObject;

out ppDORet: IDataObject): HRESULT;

begin

ppDORet := Nil;

result := S_FALSE;

end;

(*----------------------------------------------------------------------*

| TExWebBrowser.GetDropTarget |

| |

| The IE control calls this when it's used as a drop target so we can |

| provide a different ppDropTarget if we want. We don't. |

| |

| Parameters: |

| const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget

| |

| The function returns HRESULT

*----------------------------------------------------------------------*)

function TExWebBrowser.GetDropTarget(const pDropTarget: IDropTarget;

out ppDropTarget: IDropTarget): HRESULT;

begin

ppDropTarget := Nil;

result := E_NOTIMPL

end;

(*----------------------------------------------------------------------*

| TExWebBrowser.GetExternal |

| |

| IE calls this to determine our IDispatch interface. We don't have |

| one... |

*----------------------------------------------------------------------*)

function TExWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT;

begin

ppDispatch := Application;

result := S_OK

end;

function TExWebBrowser.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;

begin

FillChar (pInfo, SizeOf (pInfo), 0);

pInfo.cbSize := sizeof (TDOCHOSTUIINFO);

pInfo.cbSize := SizeOf(pInfo);

pInfo.dwFlags := 0;

if not UIProperties.EnableScrollBars then

pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_SCROLL_NO;

if UIProperties.FlatScrollBars then

pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_FLAT_SCROLLBAR;

if not UIProperties.Has3DBorder then

pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER;

if UIProperties.OpenLinksInNewWindow then

pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_OPENNEWWIN;

if not UIProperties.EnableScripting then

pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE;

result := S_OK;

end;

function TExWebBrowser.GetOptionKeyPath(var pchKey: POLESTR;

const dw: DWORD): HRESULT;

begin

result := S_FALSE;

end;

function TExWebBrowser.GetURL: string;

begin

if (csDesigning in ComponentState) then

result := fURL

else

result := self.LocationURL

end;

function TExWebBrowser.HideUI: HRESULT;

begin

result := S_OK;

end;

function TExWebBrowser.Invoke(DispID: Integer; const IID: TGUID;

LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,

ArgErr: Pointer): HResult;

const

DISPID_AMBIENT_DLCONTROL = -5512;

DLCTL_DLIMAGES = $00000010;

DLCTL_NO_SCRIPTS = $00000080;

DLCTL_NO_JAVA = $00000100;

DLCTL_NO_RUNACTIVEXCTLS = $00000200;

DLCTL_NO_DLACTIVEXCTLS = $00000400;

DLCTL_DOWNLOADONLY = $00000800;

var

ort : HRESULT;

dlc : Integer;

begin

result := inherited Invoke (DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);

if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then

begin

ort := result;

result := S_OK;

case DispID of

(*

DISPID_AMBIENT_USERMODE:

PVariant(VarResult)^ := True; // not (csDesigning in ComponentState);

*)

DISPID_AMBIENT_DLCONTROL:

begin

if UIProperties.ShowImages then

dlc := DLCTL_DLIMAGES

else

dlc := 0;

if not UIProperties.EnableJava then

dlc := dlc or DLCTL_NO_JAVA;

if not UIProperties.EnableScripting then

dlc := dlc or DLCTL_NO_SCRIPTS;

if not UIProperties.EnableDownloadActiveX then

dlc := dlc or DLCTL_NO_DLACTIVEXCTLS;

if not UIPRoperties.ShowActiveX then

dlc := dlc or DLCTL_NO_RUNACTIVEXCTLS;

PVariant(VarResult)^ := dlc

end;

else

result := ort

end

end

end;

procedure TExWebBrowser.Loaded;

begin

inherited;

if not (csDesigning in ComponentState) then

if fURL = '' then

Navigate ('about:blank')

else

Navigate (fURL);

end;

procedure TExWebBrowser.LoadFromStream(s: TStream; takeOwnership: boolean);

var

ownership : TStreamOwnership;

persistStreamInit : IPersistStreamInit;

adapter : TStreamAdapter;

begin

if Document = Nil then

Navigate ('about:blank');

if Supports (Document, IPersistStreamInit, persistStreamInit) then

begin

if takeOwnership then

ownership := soOwned

else

ownership := soReference;

adapter := TStreamAdapter.Create(s, ownership);

OleCheck (persistStreamInit.InitNew);

OleCheck (persistStreamInit.Load(adapter))

end

end;

procedure TExWebBrowser.LoadFromString(const st: string);

begin

LoadFromStream (TStringStream.Create(st), True);

end;

function TExWebBrowser.OnDocWindowActivate(const fActivate: BOOL): HRESULT;

begin

result := S_OK;

end;

function TExWebBrowser.OnFrameWindowActivate(

const fActivate: BOOL): HRESULT;

begin

result := S_OK;

end;

function TExWebBrowser.ResizeBorder(const prcBorder: PRECT;

const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;

begin

result := S_OK;

end;

procedure TExWebBrowser.SetURL(const Value: string);

begin

fURL := Value;

if (csLoading in ComponentState) or (csDesigning in ComponentState) then

Exit;

if Value = '' then

Navigate ('about:blank')

else

Navigate (value);

end;

function TExWebBrowser.ShowContextMenu(const dwID: DWORD;

const ppt: PPOINT; const pcmdtReserved: IInterface;

const pdispReserved: IDispatch): HRESULT;

begin

if UIProperties.EnableContextMenu then

result := S_FALSE

else

begin

result := S_OK;

if Assigned (PopupMenu) then

PopupMenu.Popup(ppt.X, ppt.Y)

end;

end;

function TExWebBrowser.ShowUI(const dwID: DWORD;

const pActiveObject: IOleInPlaceActiveObject;

const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;

const pDoc: IOleInPlaceUIWindow): HRESULT;

begin

result := S_FALSE; // IE will display the UI

end;

function TExWebBrowser.TranslateAccelerator(const lpMsg: PMSG;

const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;

begin

result := S_FALSE;

end;

function TExWebBrowser.TranslateUrl(const dwTranslate: DWORD;

const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;

begin

result := S_FALSE; // URL was not translated

end;

function TExWebBrowser.UpdateUI: HRESULT;

begin

result := S_FALSE;

end;

{ TUIProperties }

constructor TUIProperties.Create(AOwner: TExWebBrowser);

begin

fOwner := AOwner;

fShowImages := True;

fShowActiveX := True;

end;

end.