分享
 
 
 

利用WebBorwser和MSHTML.tlb做广告过滤器完全源码公开

王朝vb·作者佚名  2006-01-09
窄屏简体版  字體: |||超大  

程序组成:

两个引用对象: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

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

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有