程序组成: 两个引用对象: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,版权归作者,要用于商业目的请和作者联系fazhu@163.net) myIE.cls ------------------------------------------------------------------------------------------------------ Option Explicit '/////////////////////////////////////////////////////// Private body As MSHTML.HTMLBody Private Const FlashClassID As String = "CLSID:D27CDB6E-AE6D-11CF-96B8-444553540000" 'determine the refresh button is clicked Public Function Banding(item As SHDocVw.InternetExplorer) As SHDocVw.InternetExplorer Bye: Public Property Get IEHandle() As Long Private Sub Class_Initialize() m_bIsRefresh = True End Sub Private Sub Class_Terminate() 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) Private Sub mIE_DocumentComplete(ByVal pDisp As Object, URL As Variant) Private Sub mIE_DownloadBegin() Private Sub mIE_DownloadComplete() Private Sub BandingDoc(ByVal strWhere As String) Private Sub mIE_NavigateComplete2(ByVal pDisp As Object, URL As Variant) Private Sub mIE_NewWindow2(ppDisp As Object, Cancel As Boolean) Private Sub BandingDoc2(ByVal pDisp As Object) isCleaned = 0 End Sub Private Function cleanFlash(ByVal item As MSHTML.IHTMLElementCollection, ByVal item2 As MSHTML.IHTMLElementCollection) As Integer End Function Private Function cleanAnimated(ByVal item As MSHTML.IHTMLElementCollection) As Integer End Function Next i End Function Next i End Function Private Function cleanFlyingAds(ByVal item As MSHTML.IHTMLElementCollection) As Integer '///////////////////////////////////////////////////////////// Private Sub AlertBeep() Private Sub win2_onunload() ------------------------------------------------------------------------------------------------------ Windows.cls '局部变量，保存集合 Private Function Add(Key As SHDocVw.InternetExplorer) As MyIE '返回已创建的对象 Public Property Get item(vntIndexKey As Variant) As MyIE Public Property Get Count() As Long Private Sub Refresh() Proc_Err: Private Sub winShell_WindowRegistered(ByVal lCookie As Long) Private Sub winShell_WindowRevoked(ByVal lCookie As Long)
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 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 m_nPageCounter As Integer
'Private m_nObjCounter As Integer
Private m_bIsRefresh As Boolean
Private mSArrays As Variant
Private mPtr As POINTAPI
'//////////////////////////////////////////
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
If Not (tmpie Is Nothing) Then Set tmpie = Nothing
Exit Function
Err:
MsgBox "Error:" & Err.Description & " in Banding"
Resume Bye
End Function
IEHandle = mHWnd
End Property
'////////////////////////
'非弹出式广告特征集
mSArrays = Array("input", "a", "iframe", "area", "frame")
'////////////////////////
Set mDoc = Nothing
Set mIE = Nothing
End Sub
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
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
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
'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
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
'm_nPageCounter = m_nPageCounter + 1
'm_nObjCounter = m_nObjCounter + 1
'Remarked by zdj 2004-02-02
'm_bIsRefresh = False
End Sub
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
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
Set tmpdoc = Nothing
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
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
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
Bye:
Exit Function
Errs:
RecursivlyFlash = -1
Resume Bye
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
Bye:
Exit Function
Errs:
RecursivlyAnimate = -1
Resume Bye
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 & "个广告！(www.jjsoft.cn)"
End With
End Sub
'////////////////////////////////////////////////////////////
Beep 500, 500
End Sub
On Error Resume Next
' the refresh button is clicked
If mDoc.readyState = "complete" Then m_bIsRefresh = True
isLoaded = 1
End Sub
Private mCol As Collection
Private WithEvents winShell As SHDocVw.ShellWindows
'创建新对象
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
'引用集合中的一个元素时使用。
'vntIndexKey 包含集合的索引或关键字，
'这是为什么要声明为 Variant 的原因
'语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
Set item = mCol(vntIndexKey)
End Property
'检索集合中的元素数时使用。语法：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
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
End Sub
Call Refresh
End Sub
Call Refresh
End Sub
-----------------------------------------------------------------------------------------------------
文章来源于领测软件测试网 https://www.ltesting.net/
版权所有(C) 2003－2010 TestAge（领测软件测试网）|领测国际科技（北京）有限公司|软件测试工程师培训网 All Rights Reserved
北京市海淀区中关村南大街9号北京理工科技大厦1402室 京ICP备10010545号-5
技术支持和业务联系：info@testage.com.cn 电话：010-51297073