VB6 禁止浏览器下载图片,脚本,视频,音乐及ActvieX等.
一直没有找到自定义浏览器的方法,经老马推荐,找到了L-E浏览器的源码,啃了一星期,终于提取出了一份可用的代码.源码改自L-E浏览器.感谢作者.实现原理参考了COM原理与应用.另外关于代码中的OnAmbientPropertyChange -5512相信很多人会有疑问.请参照此帖[http://topic.csdn.net/u/20101117/17/b465d207-cb59-4111-bcda-5bdf3ca7f710.html].感谢hpygzhx520. 源码下载:http://lib.ldong.net/webbrowser.rar 需要有olelb.tbl(必需)和olelib2.tbl(可选) 以下是cWebbrowser的代码
Option Explicit Implements olelib.IOleClientSite Implements olelib2.IOleInPlaceSite Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long,ByVal hWndNewParent As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long,ByVal nIndex As Long,ByVal dwNewLong As Long) As Long 'Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long,lpRect As RECT) As Long Private Const GWL_USERDATA = (-21) Private m_oWebBrowser As SHDocVw.Webbrowser ' WebBrowser control Public Enum HostFlags ' MSHTML will not allow selection ' of the text in the form. hfDialog = DOCHOSTUIFLAG_DIALOG ' MSHTML will not add the Help menu ' item to the container's menu. hfDisableHelpMenu = DOCHOSTUIFLAG_DISABLE_HELP_MENU ' MSHTML does not use 3-D borders. hfNo3DBorder = DOCHOSTUIFLAG_NO3DBORDER ' MSHTML does not have scroll bars. hfNoScroll = DOCHOSTUIFLAG_SCROLL_NO ' MSHTML will not execute any ' script when loading pages. hfDisableScripInactive = DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE ' MSHTML will open a site in ' a new window when a link is ' clicked rather than browse to ' the new site using the same ' browser window. hfBrowseNew = DOCHOSTUIFLAG_OPENNEWUI ' Not implemented. hfDisableOffScreen = DOCHOSTUIFLAG_DISABLE_OFFSCREEN ' MSHTML will use flat scroll bars ' for any UI it displays. hfFlatScroll = DOCHOSTUIFLAG_FLAT_SCROLLBAR ' MSHTML will insert the <DIV> tag ' if a return is entered in edit mode. ' Without this flag,MSHTML will use ' the <P> tag. hfDivBlock = DOCHOSTUIFLAG_DIV_BLOCKDEFAULT ' MSHTML will only become UI active ' if the mouse is clicked in the ' client area of the window. It will ' not become UI active if the mouse ' is clicked on a nonclient area,such ' as a scroll bar. hfActiveClientHit = DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY ' MSHTML will consult the host ' before retrieving a behavior ' from the URL specified on the page. hfOverrideBehaviorFactory = DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY ' This flag was added to Microsoft(r) ' Internet Explorer 5 to provide font ' selection compatibility for Microsoft(r) ' Outlook(r) Express. If the flag is enabled, ' the displayed characters are inspected ' to determine whether the current font ' supports the code page. If disabled,the ' current font is used,even if it does ' not contain a glyph for the character. ' Note This flag assumes that the user is ' using Internet Explorer 5 and Outlook ' Express 4.0. hfCodePageLinkedFonts = DOCHOSTUIFLAG_CODEPAGELINKEDFONTS ' This flag was added to Internet Explorer ' 5 to control how nonnative URLs are ' transmitted over the Internet. Nonnative ' refers to characters outside the ' multibyte encoding of the URL. If this ' flag is set,the URL is not submitted ' to the server in UTF-8 encoding. hfDisableUTF8 = DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 ' This flag was added to Internet Explorer ' 5 to control how nonnative URLs are ' transmitted over the Internet. Nonnative ' refers to characters outside the ' multibyte encoding of the URL. If this ' flag is set,the URL is submitted ' to the server in UTF-8 encoding. hfEnableUTF8 = DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 ' This flag enables the AutoComplete ' feature for forms in the hosted ' browser. The Intelliforms feature will ' only be turned on if the user has ' previously enabled it. If the user has ' turned the AutoComplete feature off ' for forms,it will be off whether ' this flag is specified or not. hfEnableFormAutocomplete = DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE ' This flag enables the host to specify ' that navigation should happen in place. ' This means that applications hosting ' MSHTML directly can specify that ' navigation happen in the application's ' window. For instance,if this flag is ' set,you can click a link in HTML mail ' and navigate in the mail instead of ' opening a new Internet Explorer window. hfInPlaceNavigation = DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION ' During initialization,the host can set ' this flag to enable input method editor ' (IME) reconversion,allowing computer ' users to employ IME reconversion while ' browsing Web pages. An input method ' editor is a program that allows users to ' enter complex characters and symbols, ' such as Japanese Kanji characters,using ' a standard keyboard. For more information, ' see the International Features reference ' in the Base Services section of the ' Platform SDK. hfEnableIME = DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION 'Internet Explorer 6 or later. 'Specifies that the hosted browser should use themes for pages it displays. 'hfTheme= DOCHOSTUIFLAG_THEME = 0x00040000 hfTheme = &H40000 hfDefault = hfEnableFormAutocomplete Or hfEnableIME Or hfTheme End Enum Public Enum DownloadCtrlFlags DLCTL_DLIMAGES = &H10& DLCTL_VIDEOS = &H20& DLCTL_BGSOUNDS = &H40& DLCTL_NO_SCRIPTS = &H80& DLCTL_NO_JAVA = &H100& DLCTL_NO_RUNACTIVEXCTLS = &H200& DLCTL_NO_DLACTIVEXCTLS = &H400& DLCTL_DOWNLOADONLY = &H800& DLCTL_NO_FRAMEDOWNLOAD = &H1000& DLCTL_RESYNCHRONIZE = &H2000& DLCTL_PRAGMA_NO_CACHE = &H4000& DLCTL_NO_BEHAVIORS = &H8000& DLCTL_NO_METACHARSET = &H10000 DLCTL_URL_ENCODING_DISABLE_UTF8 = &H20000 DLCTL_URL_ENCODING_ENABLE_UTF8 = &H40000 DLCTL_FORCEOFFLINE = &H10000000 DLCTL_NO_CLIENTPULL = &H20000000 DLCTL_SILENT = &H40000000 DLCTL_OFFLINE = &H80000000 DLCTL_Default = DLCTL_BGSOUNDS Or DLCTL_DLIMAGES Or DLCTL_VIDEOS ' Or DLCTL_SILENT End Enum '????????±?μ?±?á? Private mDownloadCtrl As Long 'DownloadCtrlFlags Private mDL_Image As Boolean Private mDL_BgSound As Boolean Private mDL_Video As Boolean Private mDL_Script As Boolean Private mDL_ActiveX As Boolean Private mDL_JavaApplet As Boolean Private mDl_DlActiveX As Boolean Private vFrmWeb As Object Private Created As Boolean 'Webbrowser Hwnd Private m_hOleWindow& ' ' DownloadCtrl ' ' Returns the download control flags. This property ' is called by the WB control to get the flags. ' ' Be sure that the property ID is set to -5512. ' Public Property Get DownloadCtrlEX() As DownloadCtrlFlags DownloadCtrlEX = mDownloadCtrl End Property Public Property Let DownloadCtrlEX(ByVal NewFlags As DownloadCtrlFlags) Dim oOC As olelib.IOleControl mDownloadCtrl = NewFlags If Created Then ' Get the WB IOleControl Set oOC = m_oWebBrowser ' Notify the WB control that ' the property was changed oOC.OnAmbientPropertyChange -5512 End If End Property ' Private Sub pvCreateWBControl(objWeb As SHDocVw.Webbrowser) Dim oOleObj As olelib.IOleObject Dim oUnk As olelib.IUnknown 'Dim oFrame As IOleInPlaceFrame Dim oOC As olelib.IOleControl 'Dim tMSG As olelib.MSG Dim tRect As olelib.RECT Dim tOle As olelib.IOleWindow ' Create the WebBrowser control 'CoCreateInstance CLSID_WebBrowser,Nothing,CLSCTX_INPROC_SERVER,IID_IUnknown,oUnk ' Get the WebBrowser interface Set m_oWebBrowser = objWeb ' oUnk 'Set oUnk = Nothing ' Get the IOleObject interface Set oOleObj = m_oWebBrowser ' Set the client site oOleObj.SetClientSite Me Set tOle = m_oWebBrowser m_hOleWindow = tOle.GetWindow() ' Call GetClientRect(m_hOleWindow,tRect) ' Debug.Print tRect.Left,tRect.Right ' Activate the document 'Debug.Print vFrmWeb.hwnd,frmBrowser.Picture1.hwnd,frmBrowser.hwnd,vFrmWeb.Picture1.hwnd ' SetParent m_hOleWindow,vFrmWeb.Picture1.hwnd oOleObj.DoVerb OLEIVERB_INPLACEACTIVATE,Me,vFrmWeb.hWnd,tRect Created = True ' Force the WB control to get the ' UA and download control properties Set oOC = oOleObj oOC.OnAmbientPropertyChange -5513 oOC.OnAmbientPropertyChange -5512 'save webbrowser obj ptr into the 32-bit value associated with the window SetWindowLong m_hOleWindow,GWL_USERDATA,ObjPtr(m_oWebBrowser) Set oOleObj = Nothing Set oUnk = Nothing Set oOC = Nothing End Sub Public Property Get hWnd() As Long hWnd = m_hOleWindow End Property '--------------------------------------------------------------------------------------- ' Procedure : pvUnloadWBControl ' DateTime : 2006-10-19 20:31 ' Author : lingll ' email : lingll_xl@163.com ' Purpose : release the reference of WBControl and unload it '--------------------------------------------------------------------------------------- Public Function pvReleaseWBControl() As Boolean Dim oOleObj As olelib.IOleObject If Created Then Set oOleObj = m_oWebBrowser Set m_oWebBrowser = Nothing 'oOleObj.SetClientSite Nothing oOleObj.Close OLECLOSE_NOSAVE oOleObj.SetClientSite Nothing Set oOleObj = Nothing End If Set vFrmWeb = Nothing End Function Private Sub Class_Initialize() Call IniVars IniDownloadControl End Sub Private Function IOleClientSite_GetContainer() As olelib.IOleContainer ' Err.Raise E_NOTIMPL Set IOleClientSite_GetContainer = vFrmWeb End Function Private Function IOleClientSite_GetMoniker(ByVal dwAssign As olelib.OLEGETMONIKER,ByVal dwWhichMoniker As olelib.OLEWHICHMK) As olelib.IMoniker Err.Raise E_NOTIMPL End Function Private Sub IOleClientSite_OnShowWindow(ByVal fShow As olelib.BOOL) Err.Raise E_NOTIMPL End Sub Private Sub IOleClientSite_RequestNewObjectLayout() Err.Raise E_NOTIMPL End Sub Private Sub IOleClientSite_SaveObject() End Sub Private Sub IOleClientSite_ShowObject() 'Err.Raise E_NOTIMPL End Sub Private Sub IOleInPlaceSite_CanInPlaceActivate() End Sub Private Sub IOleInPlaceSite_ContextSensitiveHelp(ByVal fEnterMode As olelib.BOOL) End Sub Private Sub IOleInPlaceSite_DeactivateAndUndo() 'debug.Print "IOleInPlaceSite_DeactivateAndUndo" End Sub Private Sub IOleInPlaceSite_DiscardUndoState() End Sub Private Function IOleInPlaceSite_GetWindow() As Long IOleInPlaceSite_GetWindow = vFrmWeb.hWnd End Function Private Sub IOleInPlaceSite_GetWindowContext(ppFrame As olelib.IOleInPlaceFrame,ppDoc As olelib.IOleInPlaceUIWindow,lprcPosRect As olelib.RECT,lprcClipRect As olelib.RECT,lpFrameInfo As olelib.OLEINPLACEFRAMEINFO) 'Set ppFrame = vFrmWeb 'if use "Set ppFrame = vFrmWeb",the webbrowser will get hold up 'all keyboard event,then we can find we cant use left or right key 'on address bar 'if no use "Set ppFrame = vFrmWeb",we should send keys to 'webbrowser manually,in mGetMessage.GetMsgProc Set ppDoc = Me lpFrameInfo.hwndFrame = vFrmWeb.hWnd End Sub Private Sub IOleInPlaceSite_OnInPlaceActivate() 'Debug.Print "IOleInPlaceSite_OnInPlaceActivate" End Sub Private Sub IOleInPlaceSite_OnInPlaceDeactivate() 'debug.Print "IOleInPlaceSite_OnInPlaceDeactivate" End Sub Private Sub IOleInPlaceSite_OnPosRectChange(lprcPosRect As olelib.RECT) End Sub Private Sub IOleInPlaceSite_OnUIActivate() End Sub Private Sub IOleInPlaceSite_OnUIDeactivate(ByVal fUndoable As olelib.BOOL) 'debug.Print "IOleInPlaceSite_OnUIDeactivate",fUndoable End Sub Private Sub IOleInPlaceSite_Scroll(ByVal scrollX As Long,ByVal scrollY As Long) 'Debug.Print "IOleInPlaceSite_Scroll" End Sub Public Sub ResizeWeb(X&,Y&,cx&,cy&,Optional useDefault As Boolean = False) Dim oOO As IOleInPlaceObject Dim tRect As olelib.RECT ' Get the IOleInPlaceObject interface Set oOO = m_oWebBrowser ' Resize the control If useDefault Then tRect.Right = vFrmWeb.ScaleWidth tRect.Bottom = vFrmWeb.ScaleHeight Else tRect.Left = X tRect.Top = Y tRect.Right = X + cx tRect.Bottom = Y + cy End If 'SetParent m_hOleWindow,vFrmWeb.hwnd oOO.SetObjectRects tRect,tRect End Sub Public Sub INIAll(nfrm As Object,objWeb As SHDocVw.Webbrowser) 'nfrm.ScaleMode = vbPixels Set vFrmWeb = nfrm Debug.Print nfrm.Name 'If Not m_NewWinMan Is Nothing Then 'm_NewWinMan.InitObj vFrmWeb 'End If Call pvCreateWBControl(objWeb) ' Call ResizeWeb(0,True) End Sub Public Property Get Webbrowser() As SHDocVw.Webbrowser 'frmBrowser.ScaleMode = vbPixels 'Set vFrmWeb = objWB.Parent 'Debug.Print vFrmWeb.Name ' Call pvCreateWBControl(objWB) 'Call ResizeWeb(objWB.Left,objWB.Top,objWB.Width,objWB.Height,False) Set Webbrowser = m_oWebBrowser End Property Private Sub IniVars() Created = False ' Initialize properties mDownloadCtrl = DLCTL_Default mDL_BgSound = False ' True mDL_Image = False ' gDL_Image 'True mDL_Script = True 'True mDL_Video = False 'True mDL_ActiveX = True ' True mDL_JavaApplet = False 'True mDl_DlActiveX = True End Sub '3?ê??ˉ????????,??μ?mDownloadControl Private Sub IniDownloadControl() mDownloadCtrl = DLCTL_Default 'Or DLCTL_NO_DLACTIVEXCTLS 'Or DLCTL_SILENT If mDl_DlActiveX Then Else mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_DLACTIVEXCTLS End If If mDL_Image Then Else mDownloadCtrl = mDownloadCtrl Xor DLCTL_DLIMAGES End If If mDL_BgSound Then Else mDownloadCtrl = mDownloadCtrl Xor DLCTL_BGSOUNDS End If If mDL_Video Then Else mDownloadCtrl = mDownloadCtrl Xor DLCTL_VIDEOS End If If Not mDL_Script Then mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_SCRIPTS Else End If '====== ??óé vCWebMe_ProcessAction ???? ======= If Not mDL_ActiveX Then mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_RUNACTIVEXCTLS Else End If '=============================================== If Not mDL_JavaApplet Then mDownloadCtrl = mDownloadCtrl Or DLCTL_NO_JAVA Else End If Debug.Print mDownloadCtrl End Sub '================================================== '======== ????????,?êDí????μ?ê?D?,è?í??? =========== 'í??? Public Property Get DL_Image() As Boolean DL_Image = mDL_Image End Property Public Property Let DL_Image(ByVal vNewValue As Boolean) mDL_Image = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property '±3?°ò?à? Public Property Get DL_BgSound() As Boolean DL_BgSound = mDL_BgSound End Property Public Property Let DL_BgSound(ByVal vNewValue As Boolean) mDL_BgSound = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property 'êó?μ Public Property Get DL_Video() As Boolean DL_Video = mDL_Video End Property Public Property Let DL_Video(ByVal vNewValue As Boolean) mDL_Video = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property '??±? Public Property Get DL_Script() As Boolean DL_Script = mDL_Script End Property Public Property Let DL_Script(ByVal vNewValue As Boolean) mDL_Script = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property '??DDActiveX Control Public Property Get DL_ActiveX() As Boolean DL_ActiveX = mDL_ActiveX End Property Public Property Let DL_ActiveX(ByVal vNewValue As Boolean) mDL_ActiveX = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property '??DDJava Applet Public Property Get DL_JavaApplet() As Boolean DL_JavaApplet = mDL_JavaApplet End Property Public Property Let DL_JavaApplet(ByVal vNewValue As Boolean) mDL_JavaApplet = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property '????ActiveX Public Property Get Dl_DlActiveX() As Boolean Dl_DlActiveX = mDl_DlActiveX End Property Public Property Let Dl_DlActiveX(ByVal vNewValue As Boolean) mDl_DlActiveX = vNewValue Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Property 'í3ò?éè?? Public Sub Dl_EnableAll(nAll As Boolean) mDL_BgSound = nAll mDL_Image = nAll mDL_Script = nAll mDL_Video = nAll mDL_ActiveX = nAll mDL_JavaApplet = nAll mDl_DlActiveX = nAll Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Sub '?úá?éè?? Public Sub Dl_BatchSet(Optional blnImage As Boolean = True,_ Optional blnScript As Boolean = True,Optional blnBgSound As Boolean = True,_ Optional blnVideo As Boolean = True,Optional blnActiveX As Boolean = True,_ Optional blnJavaApplet As Boolean = True,Optional blnDlActiveX As Boolean = True) mDL_BgSound = blnBgSound mDL_Image = blnImage mDL_Script = blnScript mDL_Video = blnVideo mDL_ActiveX = blnActiveX mDL_JavaApplet = blnJavaApplet mDl_DlActiveX = blnDlActiveX Call IniDownloadControl DownloadCtrlEX = mDownloadCtrl m_oWebBrowser.Refresh2 1 End Sub 调用方法:在VB工程中添加此类,拉一个Webbrowser控件,用cWebbrowser的IniAll方法初始化一下,然后就可以自由控制了. Iniall方法的第一个参数是Webbrowser的容器,用于给Webbrowser定位的.第二个参数就是Webbrowser控件了. olelib2.IOleInPlaceSite是用来定位浏览器的,可以不引用. 类中包含一个hWnd属性,这是浏览器的句柄,因为尽管Webbrowser控件有hwnd属性,但似乎根本无效. (编辑:李大同) 【声明】本站内容均来自网络,其相关言论仅代表作者个人观点,不代表本站立场。若无意侵犯到您的权利,请及时与联系站长删除相关内容! |