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控件让 ...
随机推荐
- 教你看懂C++类库函数定义之一---HRESULT 宏
一切从一个C++ 类库头文件开始,现在在做一个C++的项目,期间用到一个开源的界面库DUILib(类似MFC),这个东西还不错能很容易的写出漂亮的界面,比如QQ的界面,可以去下载下来研究研究,地址:h ...
- Myeclipse 设定文件的默认打开方式
Myeclipse 设定文件的默认打开方式.今天下载了一个properties的中文插件,希望.property的文件能默认以这个程序打卡.说一下设置方法. Window -> Preferen ...
- EasyUi 中datagrid 实现查询方法
1.在初始化表格方法中添加传入參数,例如以下: //初始化表格 function initTable(<strong><span style="color:#ff6666; ...
- Hadoop 源码分析(二四)FSNamesystem
以下轮到FSNamesystem 出场了. FSNamesystem.java 一共同拥有4573 行.而整个namenode 文件夹下全部的Java 程序总共也仅仅有16876 行,把FSNames ...
- C++学习笔记(十二):重载函数
1. 什么是重载函数 假设同一作用域内的几个函数名字同样但形參列表不同.那么这些函数就称之为--重载函数. 比如: void print( const char *cp); void print(co ...
- Java 螺纹第三版 第三章数据同步 读书笔记
多线程间共享数据问题 一.Synchronizedkeyword atomic一词与"原子"无关,它以前被觉得是物质的最小的单元,不能再被拆解成更小的部分. 当 ...
- swift 自定义TabBarItem
1.效果图 2.NewsViewController.swift // // NewsViewController.swift // NavigationDemo // // Created ...
- 基于visual Studio2013解决C语言竞赛题之1026判断排序
题目 解决代码及点评 /********************************************************************** ...
- Embedded Linux Primer----嵌入式Linux基础教程--章节介绍
章节介绍 第一章,“导引”,简要介绍了Linux被迅速应用在嵌入式环境的驱动因素,介绍了与嵌入式Linux相关的几个重要的标准和组织. 第二章,“第一个嵌入式经历”,介绍了与后几章所构建的嵌入式Lin ...
- Eclipse用法和技巧十六:自动添加未实现方法2
前面一篇文章里面介绍了一种常见的自动添加未实现函数的方法.这里在顺便补充几个方法.第一个方法,看上去有点怪怪的: 步骤一:Source > Clean Up: 步骤二:选择cust ...