程序组成:
两个引用对象: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)

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 String

Private 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 = mIE

Bye:
    
     If Not (tmpie Is Nothing) Then Set tmpie = Nothing
     Exit Function
Err:
     MsgBox "Error:" & Err.Description & " in Banding"
     Resume Bye
End Function

Public Property Get IEHandle() As Long
     IEHandle = mHWnd
End Property

Private Sub Class_Initialize()
     m_bIsRefresh = True
    
     '////////////////////////
     '非弹出式广告特征集
     mSArrays = Array("input", "a", "iframe", "area", "frame")
     '////////////////////////

End Sub

Private Sub Class_Terminate()
     Set mDoc = Nothing
     Set mIE = Nothing
End Sub

Private 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 Sub

Private 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 Sub

Private Sub mIE_DownloadBegin()
     On Error Resume Next
     If Not (mDoc Is Nothing) Then Set mDoc = Nothing
     Call BandingDoc("mIE_DownloadBegin")
    
     'Remarked by zdj 2004-02-02
     'If m_bIsRefresh = False Then m_bIsRefresh = True
     'm_nObjCounter = m_nObjCounter + 1
End Sub

Private 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
    
     'Remarked by zdj 2004-02-02
     'If (m_bIsRefresh) Then
     '     isLoaded = 1
     '     Call BandingDoc2(mIE)
     'End If
     '
    
     '////////////////////////////////////////////
End Sub

Private 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 Sub

Private Sub mIE_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
         'm_nPageCounter = m_nPageCounter + 1
         'm_nObjCounter = m_nObjCounter + 1
        
         'Remarked by zdj 2004-02-02
         'm_bIsRefresh = False
End Sub

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 Sub

Private 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 = Nothing

End Sub

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 Bye

End Function

Private 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 Bye

End 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 Bye

End 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 Bye

End Function

Private Function cleanFlyingAds(ByVal item As MSHTML.IHTMLElementCollection) As Integer
     On Error GoTo Errs
     Dim i As Integer, l As Integer, j As Integer
     Dim tmpobj As Object
    
     l = item.Length
     For i = 0 To l - 1
         DoEvents
         Set tmpobj = item(i)
         If (tmpobj.Style.position = "absolute") Then
             tmpobj.Style.visibility = "hidden"
             j = j + 1
         End If
         Set tmpobj = Nothing
     Next i
     cleanFlyingAds = j
Bye:
     Exit Function
Errs:
   cleanFlyingAds = -1
   Resume Bye
End Function

'/////////////////////////////////////////////////////////////
'显示警告语
Private Sub showAlertInfo(ByVal Count As Integer)
     With win2
         .Status = "已阻止网页中符合条件的" & Count & "个广告！()"
     End With
    
End Sub
'////////////////////////////////////////////////////////////

Private Sub AlertBeep()
     Beep 500, 500
End Sub

Private Sub win2_onunload()
     On Error Resume Next
    
     ' the refresh button is clicked
     If mDoc.readyState = "complete" Then m_bIsRefresh = True
     isLoaded = 1
End Sub

------------------------------------------------------------------------------------------------------

Windows.cls

'局部变量，保存集合
Private mCol As Collection
Private WithEvents winShell As SHDocVw.ShellWindows

Private Function Add(Key As SHDocVw.InternetExplorer) As MyIE
     '创建新对象
     Dim objNewMember As MyIE
     Set objNewMember = New MyIE


     '设置传入方法的属性
     If Not objNewMember.Banding(Key) Is Nothing Then
         mCol.Add objNewMember, CStr(objNewMember.IEHandle)
     End If

     '返回已创建的对象
     Set Add = objNewMember
     Set objNewMember = Nothing


End Function

Public Property Get item(vntIndexKey As Variant) As MyIE
     '引用集合中的一个元素时使用。
     'vntIndexKey 包含集合的索引或关键字，
     '这是为什么要声明为 Variant 的原因
     '语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
   Set item = mCol(vntIndexKey)
End Property



Public Property Get Count() As Long
     '检索集合中的元素数时使用。语法：Debug.Print x.Count
     Count = mCol.Count
End Property


Public Sub Remove(vntIndexKey As Variant)
     '删除集合中的元素时使用。
     'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
     '语法：x.Remove(xyz)

     mCol.Remove vntIndexKey
End Sub

Public Property Get NewEnum() As IUnknown
     '本属性允许用 For...Each 语法枚举该集合。
     Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
     '创建类后创建集合
    
     Call Refresh
End Sub

Private Sub Class_Terminate()
     '类终止后破坏集合
     Set mCol = Nothing
     Set winShell = Nothing
End Sub

Private Sub Refresh()
    
     On Error GoTo Proc_Err
     Dim SWs As New SHDocVw.ShellWindows
     Dim var As SHDocVw.InternetExplorer
    
     Set mCol = Nothing
     Set mCol = New Collection
     For Each var In SWs
       Add var
     Next
    
    
     If ObjPtr(winShell) <> ObjPtr(SWs) Then
         Set winShell = SWs
     End If
     Set SWs = Nothing
     Set var = Nothing
     Exit Sub

Proc_Err:
    
End Sub

Private Sub winShell_WindowRegistered(ByVal lCookie As Long)
     Call Refresh
End Sub

Private Sub winShell_WindowRevoked(ByVal lCookie As Long)
     Call Refresh
End Sub