有谁知道用TwebBrowser控件怎么拦截网页的弹出广告？或者解决方案？

Question

有谁知道用TwebBrowser控件怎么拦截网页的弹出广告？或者解决方案？

Answer 1

OnNewWindow2事件写相关的代码
 ________________________欢迎访问和宣传我的论坛http://hthunter.vicp.net/

Answer 2

利用WebBorwser和MSHTML.tlb做广告过滤器完全源码公开 
（加入日期:2004-4-14 点击数:1008）
【对此文发表评论】 【编程爱好者论坛】 【保存文章至硬盘】 【打印文章】 
Borland开发讨论区 微软开发讨论区 C/C++讨论区 新手入门专区
 程序组成:两个引用对象:Microsoft HTML Object Library,Microsoft Internet Object两个窗体: frmAbout.frm frmMenu.frm两个*.bas: APIs.bas,mSysTray.bas两个Class: MyIE.cls, windows.cls(其中windows.cls是collection对象的扩展,放MyIE.cls)下面公开这两个主要类的代码(如要全部代码请留email,要看演示上www.jjsoft.cn,版权归作者,要用于商业目的请和作者联系[email protected])myIE.cls------------------------------------------------------------------------------------------------------Option Explicit
Private WithEvents mIE As SHDocVw.InternetExplorer
Private WithEvents IE_IFrame As MSHTML.HTMLIFrame
Private WithEvents win2 As MSHTML.HTMLWindow2
Private WithEvents doc2 As MSHTML.HTMLDocument'///////////////////////////////////////////////////////
'判断Frame对象
Private tmpIE_IFrame As MSHTML.HTMLIFrame
Private IE_FCols As MSHTML.FramesCollection
'///////////////////////////////////////////////////////Private body As MSHTML.HTMLBody
Private IElements As MSHTML.IHTMLElement
Private mHWnd As Long
Private mDoc As MSHTML.IHTMLDocument2
Private isLoaded As Integer
Private isClicked As Integer
Private isCleaned As Integer
Private tmpState As StringPrivate Const FlashClassID As String = "CLSID:D27CDB6E-AE6D-11CF-96B8-444553540000"'determine the refresh button is clicked
'Private m_nPageCounter As Integer
'Private m_nObjCounter As Integer
Private m_bIsRefresh As Boolean
Private mSArrays As Variant
Private mPtr As POINTAPI
'//////////////////////////////////////////Public Function Banding(item As SHDocVw.InternetExplorer) As SHDocVw.InternetExplorer
    On Error GoTo Err
    Dim tmpName As String, tmpie As SHDocVw.InternetExplorer
    'Dim tmpdoc As MSHTML.HTMLDocument
    Set tmpie = item
    If (tmpie Is Nothing) Then Exit Function
    If Not (TypeOf item Is IWebBrowser2) Then Exit Function
            
    tmpName = tmpie.FullName
    tmpName = Mid(tmpName, InStrRev(tmpName, "\") + 1)
    If UCase(tmpName) = "IEXPLORE.EXE" Then
        Set mIE = tmpie
        mHWnd = mIE.hwnd
       ' Call BandingDoc(mIE2)
    End If
    tmpName = ""
    Set tmpie = Nothing
    Set Banding = mIEBye:
    
    If Not (tmpie Is Nothing) Then Set tmpie = Nothing
    Exit Function
Err:
    MsgBox "Error:" & Err.Description & " in Banding"
    Resume Bye
End FunctionPublic Property Get IEHandle() As Long
    IEHandle = mHWnd
End PropertyPrivate Sub Class_Initialize()    m_bIsRefresh = True
    
    '////////////////////////
    '非弹出式广告特征集
    mSArrays = Array("input", "a", "iframe", "area", "frame")
    '////////////////////////End SubPrivate Sub Class_Terminate()
    Set mDoc = Nothing
    Set mIE = Nothing
End SubPrivate Sub mIE_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
    On Error Resume Next
    Dim tmpie As SHDocVw.InternetExplorer
    If Not (mDoc Is Nothing) Then
        Set mDoc = Nothing
    Else
        Exit Sub
    End If
    Call BandingDoc("mIE_BeforeNavigate2")
    'm_nPageCounter = m_nPageCounter + 1
End SubPrivate Sub mIE_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    On Error Resume Next
    'm_nPageCounter = m_nPageCounter - 1
    Call BandingDoc("mIE_DocumentComplete")
    If m_bIsRefresh Then
        If (tmpState = "interactive") Then _
            isLoaded = 1
            Call BandingDoc2(mIE)
    Else
        If (tmpState = "complete") Then _
            isLoaded = 1
            Call BandingDoc2(mIE)
    End If
End SubPrivate Sub mIE_DownloadBegin()
    On Error Resume Next
    If Not (mDoc Is Nothing) Then Set mDoc = Nothing
    Call BandingDoc("mIE_DownloadBegin")
    
    'Reed by zdj 2004-02-02
    'If m_bIsRefresh = False Then m_bIsRefresh = True
    'm_nObjCounter = m_nObjCounter + 1
End SubPrivate Sub mIE_DownloadComplete()
    'm_nObjCounter = m_nObjCounter - 1
    'Call BandingDoc("mIE_DownloadComplete")
    'If (tmpState = "complete") Then
    '    isLoading = 0
    '    Call BandingDoc2(mIE)
    'End If
    '////////////////////////////////////////////
    'The refresh button is clicked
    'If Not (m_bIsRefresh) Then m_bIsRefresh = True
    'If m_nObjCounter = 1 Then m_nObjCounter = 0
    
    'Reed by zdj 2004-02-02
    'If (m_bIsRefresh) Then
    '    isLoaded = 1
    '    Call BandingDoc2(mIE)
    'End If
    '
    
    '////////////////////////////////////////////
End SubPrivate Sub BandingDoc(ByVal strWhere As String)
    On Error GoTo Err:
    If mIE Is Nothing Then
        Exit Sub
    End If
    
    If mDoc Is Nothing Then Set mDoc = mIE.document
    tmpState = mDoc.readyState
    If tmpState <> "complete" Then isLoaded = 0
    'Debug.Print mDoc.readyState & " " & strWhere
Bye:
    Exit Sub
Err:
    If Err.Number = -2147467259 Then Resume Bye
    MsgBox Err.Number & Err.Description & strWhere
    Resume Bye
End SubPrivate Sub mIE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
        'm_nPageCounter = m_nPageCounter + 1
        'm_nObjCounter = m_nObjCounter + 1
        
        'Reed by zdj 2004-02-02
        'm_bIsRefresh = False
End Sub

Answer 3

Private Sub mIE_NewWindow2(ppDisp As Object, Cancel As Boolean)
    Dim tmpobj As IHTMLDocument2, tmpString As String
    Dim notPopups As Boolean, tmpobj2 As IHTMLElement
    Dim i As Integer
    If (BlockedPopups = True) Then
        GetCursorPos mPtr
        Set tmpobj = mIE.document
        Set tmpobj2 = tmpobj.elementFromPoint(mPtr.X, mPtr.Y)
        If tmpobj2 Is Nothing Then
            notPopups = Not (isLoaded = 0)
        Else
            If (tmpobj2.document.activeElement) Is Nothing Then
                notPopups = Not (isLoaded = 0)
            Else
                tmpString = LCase(tmpobj2.document.activeElement.tagName)
                For i = LBound(mSArrays) To UBound(mSArrays)
                    If tmpString = CStr(mSArrays(i)) Then
                        notPopups = True
                        Exit For
                    End If
                Next i
            End If
        End If
        If notPopups = False Then
            Cancel = True
            If EnabledBeep Then Beep 500, 100
            isCleaned = isCleaned + 1
        End If
    End If
    Set tmpobj2 = Nothing
    Set tmpobj = Nothing
End SubPrivate Sub BandingDoc2(ByVal pDisp As Object)
    On Error Resume Next
    Dim tmpdoc As Object, iwin As MSHTML.HTMLWindow2
    Dim tmpdoc2 As MSHTML.HTMLDocument
    Dim i As Integer, j As Integer
    Dim ii As Integer, jj As Integer
    Dim k As Integer, killed As Boolean
    
    If TypeOf pDisp Is IWebBrowser2 Then
        Call pDisp.ExecWB(OLECMDID_SHOWMESSAGE, OLECMDEXECOPT_DONTPROMPTUSER)
        Set tmpdoc = pDisp.document
        
        If TypeName(tmpdoc) = "HTMLDocument" Then
          
            Set doc2 = tmpdoc
            Set win2 = doc2.parentWindow
            Set body = doc2.body
            
            'Skip the error message
            'win2.clearTimeout (0)
            
            '绑定flash对象
            If (BlockedFlash = True) Then
                i = cleanFlash(doc2.All.tags("OBJECT"), doc2.All.tags("EMBED"))
            End If
            
            '绑定动画对象
            If (BlockedAnimate = True) Then
                j = cleanAnimated(doc2.All.tags("IMG"))
            End If
            '/////////////////////////////////
            
            If (BlockedFlying = True) Then
                k = cleanFlyingAds(doc2.All.tags("DIV"))
            End If
            
            '////////////////////////////////////////////////
            '过滤框架中的广告
                If TypeName(doc2.body) = "HTMLFrameSetSite" Then
                  If doc2.readyState = "complete" Then
                    win2.Status = "正在阻止框架中的广告..."
                    ii = RecursivlyFlash(doc2.frames)
                    jj = RecursivlyAnimate(doc2.frames)
                    'win2.Status = "阻止完毕！"
                  End If
                End If
            '////////////////////////////////////////////////
            
            '//////////////////////////////////
            ' skip the onload event in body tag
            'body.onload = ""
            body.onunload = ""
            '//////////////////////////////////
            killed = (isCleaned > 0 Or i > 0 Or j > 0 Or ii > 0 Or jj > 0 Or k > 0)
            If (killed) Then
                Call showAlertInfo(isCleaned + i + j + ii + jj + k)
            End If
        End If
    End If    isCleaned = 0
    Set tmpdoc = NothingEnd Sub

Answer 4

Private Function cleanFlash(ByVal item As MSHTML.IHTMLElementCollection, ByVal item2 As MSHTML.IHTMLElementCollection) As Integer
    
    On Error GoTo Errs
    Dim i As Integer
    Dim objelments As MSHTML.HTMLObjectElement, objstyle As MSHTML.IHTMLStyle
    Dim objembed As MSHTML.HTMLEmbed
    
    '网页中无此标签的对象
    If (item Is Nothing) Then Exit Function
    
    
    i = 0
    
    '/////////////////////////////////////////////////////////
    For Each objelments In item
        'DoEvents
        
        If Not (objelments Is Nothing) Then
            
            If (item.Length = 0) Then Exit For
            If UCase(objelments.classid) = FlashClassID Then
                
                Set objstyle = objelments.Style
                With objstyle
                    
                    .visibility = "Hidden"
                    '.Width = 0
                    '.Height = 0
                    
                End With
                Set objstyle = Nothing
                i = i + 1
            End If
         
         End If
    Next objelments
    '//////////////////////////////////////////////////////////
    
    '网页中无此标签的对象
    If (item2 Is Nothing) Then Exit Function
    
    
    For Each objembed In item2
        'DoEvents
        If Not (objembed Is Nothing) Then
            
            If (item2.Length = 0) Then Exit For
            If InStr(1, LCase(objembed.src), ".swf") > 0 Then
                
                Set objstyle = objembed.Style
                With objstyle
                    
                    .visibility = "Hidden"
                    '.Width = 0
                    '.Height = 0
                    
                End With
                Set objstyle = Nothing
            
            End If
        End If
    Next objembed
    cleanFlash = i
Bye:
    Exit Function
Errs:
    cleanFlash = -1
    Resume ByeEnd FunctionPrivate Function cleanAnimated(ByVal item As MSHTML.IHTMLElementCollection) As Integer
    
    On Error GoTo Errs
    Dim i As Integer
    Dim objImgs As MSHTML.IHTMLImgElement, objImg As MSHTML.HTMLImg
    Dim objstyle As MSHTML.IHTMLStyle
    
    '网页中无此标签的对象
    If (item Is Nothing) Then Exit Function
    i = 0
    
    For Each objImgs In item
        
        If Not (objImgs Is Nothing) Then
            
            If (item.Length = 0) Then Exit For
            
            Set objImg = objImgs
            
            Set objstyle = objImg.Style
            If InStr(1, LCase(objImg.src), ".gif") > 0 Then
                
                DoEvents
                With objstyle
                    
                    .visibility = "hidden"
                    '.Width = 0
                    '.Height = 0
                    
                End With
                i = i + 1
            
            End If
        End If
        
        Set objstyle = Nothing
        Set objImg = Nothing
       
    Next objImgs
    cleanAnimated = i
Bye:
    Exit Function
Errs:
    cleanAnimated = -1
    Resume ByeEnd Function
Private Function RecursivlyFlash(ByRef frame As FramesCollection) As Integer
        On Error GoTo Errs
        Dim X As Object, ihtmle As IHTMLElementCollection
        Dim i As Integer, spWin As IHTMLWindow2
        
        Set X = frame.document.frames
        
        If X.Length = 0 Then Exit Function
        
        For i = 0 To X.Length - 1
             'DoEvents
             Call RecursivlyFlash(X(i))
             Set ihtmle = X(i).document.All
             
             If BlockedFlash Then
                
                RecursivlyFlash = cleanFlash(ihtmle.tags("OBJECT"), ihtmle.tags("EMBED"))                
             End If
             
             Set ihtmle = Nothing        Next i
Bye:
    Exit Function
Errs:
    RecursivlyFlash = -1
    Resume ByeEnd Function
Private Function RecursivlyAnimate(ByRef frame As FramesCollection) As Integer
        
        On Error GoTo Errs
        Dim X As Object, ihtmle As IHTMLElementCollection
        Dim i As Integer, spWin As IHTMLWindow2
        
        Set X = frame.document.frames
        
        If X.Length = 0 Then Exit Function
        
        For i = 0 To X.Length - 1
             'DoEvents
             Call RecursivlyAnimate(X(i))
             Set ihtmle = X(i).document.All
             
             If BlockedAnimate Then
                
                RecursivlyAnimate = cleanAnimated(ihtmle.tags("IMG"))                
             End If
             
             Set ihtmle = Nothing        Next i
Bye:
    Exit Function
Errs:
    RecursivlyAnimate = -1
    Resume ByeEnd Function

Answer 5

wellyn(阿伟)大侠 ,我想要全部代码
email：[email protected] 多谢！

Answer 6

wellyn(阿伟)大侠：还像请教你一个问题！
IE 中 通过查看--工具栏 可选择让地址栏消失 或者是自定义的工具栏消失（出现）
如何通过修改注册表的方式来实现？偶已经用delphi实现了自定义的toolband(or toolbar）
但是安装（注册）后需要人工才能让他出现 :(
能否修改注册表就ok ？
email：[email protected] 多谢！