Delphi 中TWebBrowser的扩展控件TExWebBrowser

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