主要扩展了3D界面、右键菜单、是否显示图片、是否支持JAVA等功能。

代码如下：

  1. unit ExtWebBrowser;
  2. interface
  3. uses
  4. Windows, SysUtils, Classes, Controls, OleCtrls, SHDocVw, ActiveX, Forms, URLMon;
  5. type
  6. TDocHostUIInfo = packed record
  7. cbSize : ULONG;
  8. dwFlags : DWORD;
  9. dwDoubleClick : DWORD;
  10. pchHostCss : polestr;
  11. pchHostNS : polestr;
  12. end;
  13. pDocHostUIInfo = ^TDocHostUIInfo;
  14. IDocHostUIHandler = interface(IUnknown)
  15. ['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}']
  16. function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch):HRESULT; stdcall;
  17. function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
  18. function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
  19. function HideUI: HRESULT; stdcall;
  20. function UpdateUI: HRESULT; stdcall;
  21. function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
  22. function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
  23. function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
  24. function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT; stdcall;
  25. function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup:PGUID; const nCmdID: DWORD): HRESULT; stdcall;
  26. function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD):HRESULT; stdcall;
  27. function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall;
  28. function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
  29. function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall;
  30. function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall;
  31. end;
  32. ICustomDoc = interface (IUnknown)
  33. ['{3050F3F0-98B5-11CF-BB82-00AA00BDCE0B}']
  34. function SetUIHandler (const pUIHandler : IDocHostUIHandler) : HRESULT; stdcall;
  35. end;
  36. TExWebBrowser = class;
  37. TUIProperties = class (TPersistent)
  38. private
  39. fOwner : TExWebBrowser;
  40. fEnableContextMenu: boolean;
  41. fEnableScrollBars: boolean;
  42. fFlatScrollBars: boolean;
  43. fHas3DBorder: boolean;
  44. fOpenLinksInNewWindow: boolean;
  45. fEnableScripting: boolean;
  46. fShowImages: boolean;
  47. fShowActiveX: boolean;
  48. fEnableDownloadActiveX: boolean;
  49. fEnableJava: boolean;
  50. public
  51. constructor Create (AOwner : TExWebBrowser);
  52. published
  53. property EnableContextMenu : boolean read fEnableContextMenu write fEnableContextMenu;
  54. property EnableScrollBars : boolean read fEnableScrollBars write fEnableScrollBars;
  55. property FlatScrollBars : boolean read fFlatScrollBars write fFlatScrollBars;
  56. property Has3DBorder : boolean read fHas3DBorder write fHas3DBorder;
  57. property OpenLinksInNewWindow : boolean read fOpenLinksInNewWindow write fOpenLinksInNewWindow;
  58. property EnableScripting : boolean read fEnableScripting write fEnableScripting;
  59. property EnableJava : boolean read fEnableJava write fEnableJava;
  60. property EnableDownloadActiveX : boolean read fEnableDownloadActiveX write fEnableDownloadActiveX;
  61. property ShowImages : boolean read fShowImages write fShowImages default True;
  62. property ShowActiveX : boolean read fShowActiveX write fShowActiveX default True;
  63. end;
  64. TExWebBrowser = class(TWebBrowser, IDocHostUIHandler, IDispatch)
  65. private
  66. fUIProperties : TUIProperties;
  67. fURL : string;
  68. fInternetSession : IInternetSession;
  69. { IDispatch }
  70. function IDispatch.Invoke = Invoke;
  71. function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  72. { IDocHostUIHandler }
  73. function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT; const pcmdtReserved: IUnknown; const pdispReserved: IDispatch):HRESULT; stdcall;
  74. function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
  75. function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject; const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
  76. function HideUI: HRESULT; stdcall;
  77. function UpdateUI: HRESULT; stdcall;
  78. function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
  79. function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
  80. function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
  81. function ResizeBorder(const prcBorder: PRECT; const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT; stdcall;
  82. function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup:PGUID; const nCmdID: DWORD): HRESULT; stdcall;
  83. function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD):HRESULT; stdcall;
  84. function GetDropTarget(const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget): HRESULT; stdcall;
  85. function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
  86. function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT; stdcall;
  87. function FilterDataObject(const pDO: IDataObject; out ppDORet: IDataObject): HRESULT; stdcall;
  88. function GetURL: string;
  89. procedure SetURL(const Value: string);
  90. protected
  91. procedure Loaded; override;
  92. public
  93. constructor Create (AOwner : TComponent); override;
  94. destructor Destroy; override;
  95. procedure LoadFromString (const st : string);
  96. procedure LoadFromStream (s : TStream; takeOwnership : boolean = false);
  97. published
  98. property UIProperties : TUIProperties read fUIProperties write fUIProperties;
  99. property URL : string read GetURL write SetURL;
  100. end;
  101. implementation
  102. uses ComObj;
  103. const
  104. DOCHOSTUIFLAG_DIALOG = $00000001;
  105. DOCHOSTUIFLAG_DISABLE_HELP_MENU = $00000002;
  106. DOCHOSTUIFLAG_NO3DBORDER = $00000004;
  107. DOCHOSTUIFLAG_SCROLL_NO = $00000008;
  108. DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = $00000010;
  109. DOCHOSTUIFLAG_OPENNEWWIN = $00000020;
  110. DOCHOSTUIFLAG_DISABLE_OFFSCREEN = $00000040;
  111. DOCHOSTUIFLAG_FLAT_SCROLLBAR = $00000080;
  112. DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = $00000100;
  113. DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = $00000200;
  114. DOCHOSTUIFLAG_OVERRIDEBEHAVIOURFACTORY = $00000400;
  115. DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = $00000800;
  116. DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = $00001000;
  117. DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = $00002000;
  118. DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = $00004000;
  119. { TExWebBrowser }
  120. constructor TExWebBrowser.Create(AOwner: TComponent);
  121. ///var
  122. //  Factory : IClassFactory;
  123. begin
  124. inherited Create (AOwner);
  125. fUIProperties := TUIProperties.Create (self);
  126. OleCheck (CoInternetGetSession (0, fInternetSession, 0));
  127. if fInternetSession <> Nil then
  128. begin
  129. //    CoGetClassObject(Class_CIDMimeFilter, CLSCTX_SERVER, nil, IClassFactory, Factory);
  130. //    OleCheck (fInternetSession.RegisterMimeFilter(Factory, Class_CIDMimeFilter, 'cid'));
  131. //    OleCheck (fInternetSession.RegisterNameSpace(Factory, CLASS_CIDMIMEFilter, 'cid', 0, nil, 0))
  132. end
  133. end;
  134. destructor TExWebBrowser.Destroy;
  135. begin
  136. fUIProperties.Free;
  137. inherited;
  138. end;
  139. (*----------------------------------------------------------------------*
  140. | TExWebBrowser.EnableModeless                                         |
  141. |                                                                      |
  142. | IE calls this to tell us that our dialogs should be modeless.        |
  143. *----------------------------------------------------------------------*)
  144. function TExWebBrowser.EnableModeless(const fEnable: BOOL): HRESULT;
  145. begin
  146. result := S_OK;
  147. end;
  148. (*----------------------------------------------------------------------*
  149. | TExWebBrowser.FilterDataObject                                       |
  150. |                                                                      |
  151. | IE calls this before putting data objects on the clipboard.  It      |
  152. | allows us to replace them or set them to nil.                        |
  153. |                                                                      |
  154. | The function returns S_FALSE meaning we didn't replace the object    |
  155. *----------------------------------------------------------------------*)
  156. function TExWebBrowser.FilterDataObject(const pDO: IDataObject;
  157. out ppDORet: IDataObject): HRESULT;
  158. begin
  159. ppDORet := Nil;
  160. result := S_FALSE;
  161. end;
  162. (*----------------------------------------------------------------------*
  163. | TExWebBrowser.GetDropTarget                                          |
  164. |                                                                      |
  165. | The IE control calls this when it's used as a drop target so we can  |
  166. | provide a different ppDropTarget if we want.  We don't.              |
  167. |                                                                      |
  168. | Parameters:                                                          |
  169. |   const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget
  170. |                                                                      |
  171. | The function returns HRESULT
  172. *----------------------------------------------------------------------*)
  173. function TExWebBrowser.GetDropTarget(const pDropTarget: IDropTarget;
  174. out ppDropTarget: IDropTarget): HRESULT;
  175. begin
  176. ppDropTarget := Nil;
  177. result := E_NOTIMPL
  178. end;
  179. (*----------------------------------------------------------------------*
  180. | TExWebBrowser.GetExternal                                            |
  181. |                                                                      |
  182. | IE calls this to determine our IDispatch interface.  We don't have   |
  183. | one...                                                               |
  184. *----------------------------------------------------------------------*)
  185. function TExWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT;
  186. begin
  187. ppDispatch := Application;
  188. result := S_OK
  189. end;
  190. function TExWebBrowser.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
  191. begin
  192. FillChar (pInfo, SizeOf (pInfo), 0);
  193. pInfo.cbSize := sizeof (TDOCHOSTUIINFO);
  194. pInfo.cbSize := SizeOf(pInfo);
  195. pInfo.dwFlags := 0;
  196. if not UIProperties.EnableScrollBars then
  197. pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_SCROLL_NO;
  198. if UIProperties.FlatScrollBars then
  199. pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_FLAT_SCROLLBAR;
  200. if not UIProperties.Has3DBorder then
  201. pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER;
  202. if UIProperties.OpenLinksInNewWindow then
  203. pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_OPENNEWWIN;
  204. if not UIProperties.EnableScripting then
  205. pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE;
  206. result := S_OK;
  207. end;
  208. function TExWebBrowser.GetOptionKeyPath(var pchKey: POLESTR;
  209. const dw: DWORD): HRESULT;
  210. begin
  211. result := S_FALSE;
  212. end;
  213. function TExWebBrowser.GetURL: string;
  214. begin
  215. if (csDesigning in ComponentState) then
  216. result := fURL
  217. else
  218. result := self.LocationURL
  219. end;
  220. function TExWebBrowser.HideUI: HRESULT;
  221. begin
  222. result := S_OK;
  223. end;
  224. function TExWebBrowser.Invoke(DispID: Integer; const IID: TGUID;
  225. LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  226. ArgErr: Pointer): HResult;
  227. const
  228. DISPID_AMBIENT_DLCONTROL  = -5512;
  229. DLCTL_DLIMAGES            = $00000010;
  230. DLCTL_NO_SCRIPTS          = $00000080;
  231. DLCTL_NO_JAVA             = $00000100;
  232. DLCTL_NO_RUNACTIVEXCTLS   = $00000200;
  233. DLCTL_NO_DLACTIVEXCTLS    = $00000400;
  234. DLCTL_DOWNLOADONLY        = $00000800;
  235. var
  236. ort : HRESULT;
  237. dlc : Integer;
  238. begin
  239. result := inherited Invoke (DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
  240. if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
  241. begin
  242. ort := result;
  243. result := S_OK;
  244. case DispID of
  245. (*
  246. DISPID_AMBIENT_USERMODE:
  247. PVariant(VarResult)^ := True; // not (csDesigning in ComponentState);
  248. *)
  249. DISPID_AMBIENT_DLCONTROL:
  250. begin
  251. if UIProperties.ShowImages then
  252. dlc := DLCTL_DLIMAGES
  253. else
  254. dlc := 0;
  255. if not UIProperties.EnableJava then
  256. dlc := dlc or DLCTL_NO_JAVA;
  257. if not UIProperties.EnableScripting then
  258. dlc := dlc or DLCTL_NO_SCRIPTS;
  259. if not UIProperties.EnableDownloadActiveX then
  260. dlc := dlc or DLCTL_NO_DLACTIVEXCTLS;
  261. if not UIPRoperties.ShowActiveX then
  262. dlc := dlc or DLCTL_NO_RUNACTIVEXCTLS;
  263. PVariant(VarResult)^ := dlc
  264. end;
  265. else
  266. result := ort
  267. end
  268. end
  269. end;
  270. procedure TExWebBrowser.Loaded;
  271. begin
  272. inherited;
  273. if not (csDesigning in ComponentState) then
  274. if fURL = '' then
  275. Navigate ('about:blank')
  276. else
  277. Navigate (fURL);
  278. end;
  279. procedure TExWebBrowser.LoadFromStream(s: TStream; takeOwnership: boolean);
  280. var
  281. ownership : TStreamOwnership;
  282. persistStreamInit : IPersistStreamInit;
  283. adapter : TStreamAdapter;
  284. begin
  285. if Document = Nil then
  286. Navigate ('about:blank');
  287. if Supports (Document, IPersistStreamInit, persistStreamInit) then
  288. begin
  289. if takeOwnership then
  290. ownership := soOwned
  291. else
  292. ownership := soReference;
  293. adapter := TStreamAdapter.Create(s, ownership);
  294. OleCheck (persistStreamInit.InitNew);
  295. OleCheck (persistStreamInit.Load(adapter))
  296. end
  297. end;
  298. procedure TExWebBrowser.LoadFromString(const st: string);
  299. begin
  300. LoadFromStream (TStringStream.Create(st), True);
  301. end;
  302. function TExWebBrowser.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
  303. begin
  304. result := S_OK;
  305. end;
  306. function TExWebBrowser.OnFrameWindowActivate(
  307. const fActivate: BOOL): HRESULT;
  308. begin
  309. result := S_OK;
  310. end;
  311. function TExWebBrowser.ResizeBorder(const prcBorder: PRECT;
  312. const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;
  313. begin
  314. result := S_OK;
  315. end;
  316. procedure TExWebBrowser.SetURL(const Value: string);
  317. begin
  318. fURL := Value;
  319. if (csLoading in ComponentState) or (csDesigning in ComponentState) then
  320. Exit;
  321. if Value = '' then
  322. Navigate ('about:blank')
  323. else
  324. Navigate (value);
  325. end;
  326. function TExWebBrowser.ShowContextMenu(const dwID: DWORD;
  327. const ppt: PPOINT; const pcmdtReserved: IInterface;
  328. const pdispReserved: IDispatch): HRESULT;
  329. begin
  330. if UIProperties.EnableContextMenu then
  331. result := S_FALSE
  332. else
  333. begin
  334. result := S_OK;
  335. if Assigned (PopupMenu) then
  336. PopupMenu.Popup(ppt.X, ppt.Y)
  337. end;
  338. end;
  339. function TExWebBrowser.ShowUI(const dwID: DWORD;
  340. const pActiveObject: IOleInPlaceActiveObject;
  341. const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
  342. const pDoc: IOleInPlaceUIWindow): HRESULT;
  343. begin
  344. result := S_FALSE;  // IE will display the UI
  345. end;
  346. function TExWebBrowser.TranslateAccelerator(const lpMsg: PMSG;
  347. const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
  348. begin
  349. result := S_FALSE;
  350. end;
  351. function TExWebBrowser.TranslateUrl(const dwTranslate: DWORD;
  352. const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
  353. begin
  354. result := S_FALSE;   // URL was not translated
  355. end;
  356. function TExWebBrowser.UpdateUI: HRESULT;
  357. begin
  358. result := S_FALSE;
  359. end;
  360. { TUIProperties }
  361. constructor TUIProperties.Create(AOwner: TExWebBrowser);
  362. begin
  363. fOwner := AOwner;
  364. fShowImages := True;
  365. fShowActiveX := True;
  366. end;
  367. end.
 
 

http://blog.csdn.net/missmecn/article/details/2292758

Delphi 中TWebBrowser的扩展控件TExWebBrowser的更多相关文章

  1. Delphi中解析Xml的控件-SimDesign NativeXml

    Delphi中解析Xml的控件-SimDesign NativeXml 正在学习,感觉应用很方便.无源代码的版本还是免费的. SimDesign.NativeXml是一个delphi和bcb的XML控 ...

  2. 对delphi中的数据敏感控件的一点探索

    一直对delphi数据敏感控件很好奇,感觉很神奇.只要简单设置一下,就显示和编辑数据,不用写一行代码. 如果不用数据敏感控件,编辑一个表字段数据并保存,我相信应用如下代码. Table1.edit, ...

  3. delphi中使用MSWINSCK.OCX控件

    1.首先是把winsck控件导入到delphi中,就是导入一个ActiveX控件,步骤略过. 2.将导入的winsck控件拖入你的Form中. 3.对winsck进行基本设置(IP,Port). 4. ...

  4. 多年前写的文本框扩展控件(有ValueChanging事件等)，已放github

    本文版权归mephisto和博客园共有,欢迎转载,但须保留此段声明,并给出原文链接,谢谢合作. 文章是哥(mephisto)写的,SourceLink 阅读目录 介绍 起因 代码 使用 GitHub ...

  5. Delphi下使用Oracle Access控件组下TOraSession控件链接

    Delphi下使用Oracle Access控件组下TOraSession控件链接数据库,使用  orsn1.Options.Direct:=true;  orsn1.Server:=IP:Port: ...

  6. 在Winform开发框架中，利用DevExpress控件实现数据的快速录入和选择

    在实际的项目开发过程中,有好的控件或者功能模块,我都是想办法尽可能集成到我的WInform开发框架中,这样后面开发项目起来,就可以节省很多研究时间,并能重复使用,非常高效方便.在我很早之前的一篇博客& ...

  7. JavaFX的扩展控件库ControlsFX介绍

    声明:   本博客文章原创类别的均为个人原创,版权所有.转载请注明出处: http://blog.csdn.net/ml3947,另外本人的个人博客:http://www.wjfxgame.com. ...

  8. WPF自定义控件（三）の扩展控件

    扩展控件,顾名思义就是对已有的控件进行扩展,一般继承于已有的原生控件,不排除继承于自定义的控件,不过这样做意义不大,因为既然都自定义了,为什么不一步到位呢,有些不同的需求也可以通过此来完成,不过类似于 ...

  9. Delphi 10 Seattle 小票打印控件TQ_Printer

    TQ_Printrer控件,是一个为方便需要控制打印命令而设计的跨平台专用控件,已包含标准ESC/POS打印控制的基本指令在内(这些基本指令已能很好的满足多数项目使用). TQ_Printrer控件让 ...

随机推荐

  1. java io学习记录（路径分隔符）

    java路径分隔符(路径表示) path="E:\\xp\\test\\2.jpg"; path="E:/xp/test/2.jpg"; path=" ...

  2. 教你在mac上配置adb环境变量

    1.打开终端,一次输入如下命令 cd ~ touch .bash_profile open -e .bash_profile 2.这时候会在TextEdit中打开一个空白文档,输入下面的语句 a. 输 ...

  3. Spring MVC视图层：thymeleaf vs. JSP

    本文对比了同一Spring MVC工程中相同页面(一个订阅表单)分别采用Thymeleaf和JSP(包括JSP.JSTL.Spring tag lib)两种方式的实现. 本文的所有代码来自一个可运行的 ...

  4. 关于运行robotium提示连接不上jar问题

    robotium运行测试helloworld报错: java.lang.NoClassDefFoundError: com.jayway.android.robotium.solo.Solo at c ...

  5. [置顶] android 自定义TextView

    系统自带的控件TextView有时候没满一行就换行了,为了解决这个问题,自定义了一个TextView,只有一行显示不完全的情况下才会去换行显示,代码如下: package com.open.textv ...

  6. Unity Interface Serialization-Expose Interface field In Inspector

    Unity has some quirks about their inspector, so as a preface they are listed here: If you add a [Ser ...

  7. C# 中 双问号??的用法

    int? x = null;int y = x ?? -1; 这里的y不能为null,但是等于x,x为null时赋值给y会报错.?? 可以在x==null时对y赋值-1 更多相关资料:https:// ...

  8. Integer ==与Equals【原创】

    package Equals; public class IntegerEquals { public static void main(String[] args) { printLine(128) ...

  9. VM中装Linux换ISO文件报错"该光盘无法被挂载"

    一.发现问题 利用VM安装Red Hat Linux的时候,第一个iso安装完毕,准备换第二个iso,报错“该光盘无法被挂载”. 二.解决办法 上面的菜单栏中“虚拟机”—>“设置”—>“硬 ...

  10. java-创建线程的两种方式

    1. 继承Thread类 定义类继承Thread类. 覆盖run方法. 实例化子类对象,调用start()方法,从而调用run方法. 2.实现Runnable接口 定义类实现Runnable接口. 覆 ...