兩個引用對象: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 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 & "個廣告！(www.jjsoft.cn)"
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
延伸閱讀
文章來源于領測軟件測試網 http://www.kjueaiud.com/
