Delphi 中TWebBrowser的扩展控件TExWebBrowser
主要扩展了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.
http://blog.csdn.net/missmecn/article/details/2292758
Delphi 中TWebBrowser的扩展控件TExWebBrowser的更多相关文章
- Delphi中解析Xml的控件-SimDesign NativeXml
Delphi中解析Xml的控件-SimDesign NativeXml 正在学习,感觉应用很方便.无源代码的版本还是免费的. SimDesign.NativeXml是一个delphi和bcb的XML控 ...
- 对delphi中的数据敏感控件的一点探索
一直对delphi数据敏感控件很好奇,感觉很神奇.只要简单设置一下,就显示和编辑数据,不用写一行代码. 如果不用数据敏感控件,编辑一个表字段数据并保存,我相信应用如下代码. Table1.edit, ...
- delphi中使用MSWINSCK.OCX控件
1.首先是把winsck控件导入到delphi中,就是导入一个ActiveX控件,步骤略过. 2.将导入的winsck控件拖入你的Form中. 3.对winsck进行基本设置(IP,Port). 4. ...
- 多年前写的文本框扩展控件(有ValueChanging事件等),已放github
本文版权归mephisto和博客园共有,欢迎转载,但须保留此段声明,并给出原文链接,谢谢合作. 文章是哥(mephisto)写的,SourceLink 阅读目录 介绍 起因 代码 使用 GitHub ...
- Delphi下使用Oracle Access控件组下TOraSession控件链接
Delphi下使用Oracle Access控件组下TOraSession控件链接数据库,使用 orsn1.Options.Direct:=true; orsn1.Server:=IP:Port: ...
- 在Winform开发框架中,利用DevExpress控件实现数据的快速录入和选择
在实际的项目开发过程中,有好的控件或者功能模块,我都是想办法尽可能集成到我的WInform开发框架中,这样后面开发项目起来,就可以节省很多研究时间,并能重复使用,非常高效方便.在我很早之前的一篇博客& ...
- JavaFX的扩展控件库ControlsFX介绍
声明: 本博客文章原创类别的均为个人原创,版权所有.转载请注明出处: http://blog.csdn.net/ml3947,另外本人的个人博客:http://www.wjfxgame.com. ...
- WPF自定义控件(三)の扩展控件
扩展控件,顾名思义就是对已有的控件进行扩展,一般继承于已有的原生控件,不排除继承于自定义的控件,不过这样做意义不大,因为既然都自定义了,为什么不一步到位呢,有些不同的需求也可以通过此来完成,不过类似于 ...
- Delphi 10 Seattle 小票打印控件TQ_Printer
TQ_Printrer控件,是一个为方便需要控制打印命令而设计的跨平台专用控件,已包含标准ESC/POS打印控制的基本指令在内(这些基本指令已能很好的满足多数项目使用). TQ_Printrer控件让 ...
随机推荐
- [转]Permission denied: /.htaccess pcfg_openfile: unable to check htaccess file, ensure it is readable
原文链接:http://blog.csdn.net/dyw/article/details/6612497 近日,在Apache2环境下部署Rails3应用时碰到此错误: Permission den ...
- 知识点1-2:ASP.NET MVC背景
1.发展阶段 CGI(公共网关接口)-->ASP(Active Server Pages,活动服务器页面)-->.NET 2. .NET平台 2002年初,微软发布了第一版.NET框架,这 ...
- 泛虚拟化技术(以Xen为例)
一.概述 最主要的特点是:修改Guest OS的内核代码.通过修改内核,使Guest OS明白自己是运行在R-1,不要直接去运行特权指令,如果要运行就去Hypercall(主动VMM陷入). ...
- PHP - 设置地址栏小图标
效果: 1/把icon图标直接放到根目录. 2/在header标签中写下: <link rel="icon" type="image/x-icon" hr ...
- Oracle数据库索引使用及索引失效总结
容易引起oracle索引失效的原因很多: 1.在索引列上使用函数.如SUBSTR,DECODE,INSTR等,对索引列进行运算.需要建立函数索引就可以解决了. 2.新建的表还没来得及生成统计信息,分析 ...
- 嵌入式环境:CentOS下添加用户并且让用户获得root权限
CentOS下添加用户并且让用户获得root权限 http://www.centoscn.com/CentOS/config/2014/0810/3471.html 1.添加用户,首先用adduser ...
- 关于 调用 JNI JAR 的说明和注意事项,调用第三方 JAR SDK 和 翻译 安卓 JAVA 代码 的说明 V2015.6.10
关于 调用 JNI JAR 的说明和注意事项,调用第三方 JAR SDK 和 翻译 安卓 JAVA 代码 的说明 V2015.6.10 转载请标明出处,否则死全家.选择[复制链接]即可得到出处. (* ...
- perl use utf8
utf8 Perl编译 来启用/禁用 UTF-8(or UTF-EBCDIC) 在源代码里 简洁: use utf8; no utf8; # Convert the internal represen ...
- lua中打印所以类型功能实现table嵌套table
lua中打印所以类型功能实现 本人測试 number.string.bool.nil.table嵌套table.userdata没问题 共享一下有什么问题请拍砖 代码例如以下 cclog = func ...
- ORACLE11.2.0 SQLPLUS 报 error while loading shared libraries
相应的环境平台: OS: Linux TEST11G 2.6.18-8.el5 #1 SMP Fri Jan 26 14:15:21 EST 2007 i686 i686 i386 GNU/Linux ...