Delphi 中TWebBrowser的扩展控件TExWebBrowser

2023-07-23 22:28:22

主要扩展了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

上一篇：Python 入门基础20 --面向对象_继承、组合


下一篇：Delphi处理TWebBrowser的Close事件