Delphi 中TWebBrowser的扩展控件TExWebBrowser

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

代码如下：

 

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

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

posted @ 2016-03-17 23:38  findumars  Views(1385)  Comments(1)  Edit  收藏  举报