教程(视频,书籍)下载:  ASP.NET AutoCAD 数据库 C# ASP java photoshop 网页设计 delphi 3dmax Flash C++ VB 张孝祥 实例   更多请进入BIBIDU搜索

建立一个模块，引用MSHTMLCtl

Option Explicit

Public Function FindADTitle(ByVal vTitle As String) As Boolean
    Dim S As String
    If Not p_bFilterAD Then Exit Function
    S = LCase(vTitle)
    If InStr(1, S, "ad") > 0 Then FindADTitle = True
    If InStr(1, S, "公告") > 0 Then FindADTitle = True
    If InStr(1, S, "about") > 0 Then FindADTitle = True
    If InStr(1, S, "看后吧") > 0 Then FindADTitle = True
    If InStr(1, S, "广告") > 0 Then FindADTitle = True
End Function

'过滤具有广告特征的链接
Public Function FindADURL(ByVal vURL As String) As Boolean
    Dim S As String, F As String, S1() As String
    Dim Hi As Long, Low As Long, N As Long, V As Variant
    If Not p_bFilterAD Then Exit Function
    S = LCase(vURL)
    '特征字符串
    F = "/ad,/ebay/,banner,pop,button,richang,/mall/,move"
    S1 = Split(F, ",")
    Hi = UBound(S1)
    Low = LBound(S1)
    For N = Low To Hi
        If InStr(1, S, S1(N)) > 0 Then
            FindADURL = True
            Exit For
        End If
    Next N
End Function

'请除漂浮广告和GIF动画

Public Sub CleanFlyingANDGifAD(vDoc As HTMLDocument)
    Dim S1 As String
    Dim Item As Object, S As String
    If Not p_bFilterAD Then Exit Sub
    On Error GoTo ERRORHANDL
    If vDoc Is Nothing Then Exit Sub
    For Each Item In vDoc.images
        S = Item.src
        If FindADURL(S) = True Then
            Item.Style.visibility = "hidden"
            Item.Style.Height = 0
            Item.Style.Width = 0
        End If
        If (Item.Style.Position = "absolute") Then
            Item.Style.visibility = "hidden"
            Item.Style.Height = 0
            Item.Style.Width = 0
        End If
    Next Item
    Set Item = Nothing
Exit Sub
ERRORHANDL:
    Resume Next
End Sub

'===================================================

'清除flash动画
'====================================================
Public Sub CleanFlash(vDoc As HTMLDocument)
    Dim Items As IHTMLElementCollection
    Dim Item As Object
    If Not p_bFilterAD Then Exit Sub
    On Error GoTo ERRORHANDL
    Set Items = vDoc.All.tags("OBJECT")
    If Items Is Nothing Then Exit Sub
10:
    For Each Item In Items
        If Not (Item Is Nothing) Then
            If UCase(Item.classid) = "CLSID:D27CDB6E-AE6D-11CF-96B8-444553540000" Then
                Item.Style.visibility = "hidden"
                Item.Style.Height = 0
                Item.Style.Width = 0
            End If
        End If
    Next Item
    Set Items = Nothing
    Set Item = Nothing
    CleanFlashA vDoc
Exit Sub
ERRORHANDL:
    GoTo 10
End Sub

Public Sub CleanFlashA(vDoc As HTMLDocument)
    Dim Items As IHTMLElementCollection
    Dim Item As Object
    If Not p_bFilterAD Then Exit Sub

来源:www.upschool.com.cn
作者:未知
关键字：VB,清除广告,广告拦截,Webbrowser,MSHTMLCtl
发表日期：2007-2-9 16:28:42

上一篇：VB 获取系统26项配置信息   下一篇：VB 将域名转换成IP地址

共2页 9 7 [1] [2] 8 :>

本文的相类似文章

VB读出一个进程中所有的模块名和模块路径 用VB创建开始菜单快捷方式（无需其他DLL） VB 将域名转换成IP地址 用Webbrowser控件MSHTMLCtl清除广告 VB 获取系统26项配置信息 VB UTF-8编码转换 VB 打开记录集的参数 VB断开网络连接！API源码 VB 读取收藏夹里的URL地址 VB 修改分辨率(不用重启)

网友评论 查看本文全部评论
笔 名：	*
评 论：	最多500字。当前字数：0
联系方式：
验证码：