去除HTML里的标签

<%
Dim WoDig
Set WoDig = New Woddig_Class
Class Woddig_Class
'截取定义长度的字符。。。。
Public Function get_StrLen(str,len2)
   if str = "" or isNull(str) or len2 = 0 then
    get_StrLen = ""
   else
    if len(str) < len2 then
     get_strLen = str
    else
     get_strLen = left(str,len2) & "。。。 "
    end if
   end if
End Function

网站建设哪家好，找创新互联公司！专注于网页设计、网站建设、微信开发、重庆小程序开发、集团企业网站建设等服务项目。为回馈新老客户创新互联还提供了当涂免费建站欢迎大家使用！

'专门用来去除内容中的文本害码。。。
Public Function DecodeFilter(html, filter)
   html=LCase(html)
   filter=split(filter,",")
   For Each i In filter
    Select Case i
     Case "SCRIPT"   ' 去除所有客户端脚本javascipt,vbscript,jscript,js,vbs,event,...
      html = exeRE("(javascript|jscript|vbscript|vbs):", "#", html)
      html = exeRE("]*>", "", html)
      html = exeRE("on(mouse|exit|error|click|key)", "", html)
     Case "TABLE":   ' 去除表格

      html = exeRE("]*>", "", html)
      html = exeRE("]*>", "", html)
      html = exeRE("]*>", "", html)
      html = exeRE("]*>", "", html)
      html = exeRE("]*>", "", html)
     Case "CLASS"   ' 去除样式类class=""
      html = exeRE("(<[^>]+) class=[^ |^>]*([^>]*>)", "$1 $2", html)
     Case "STYLE"   ' 去除样式style=""
      html = exeRE("(<[^>]+) style=""[^""]*""([^>]*>)", "$1 $2", html)
      html = exeRE("(<[^>]+) style='[^']*'([^>]*>)", "$1 $2", html)
     Case "IMG"   ' 去除样式style=""
      html = exeRE("]*>", "", html)
     Case "XML"   ' 去除XML
      html = exeRE("<[^>]*>", "", html)
     Case "NAMESPACE" ' 去除命名空间
      html = exeRE("<\/?[a-z]+:[^>]*>", "", html)
     Case "FONT"   ' 去除字体
      html = exeRE("]*>", "", html)
     Case "MARQUEE"   ' 去除字幕
      html = exeRE("]*>", "", html)
     Case "OBJECT"   ' 去除对象

      html = exeRE("]*>", "", html)
      html = exeRE("]*>", "", html)
      'html = exeRE("]*>", "", html)
     Case "EMBED"
        html =   exeRE("]*>", "", html)
     Case "DIV"   ' 去除对象

      html = exeRE("])*>", "$1", html)
     Case "ONLOAD"   ' 去除样式style=""
      html = exeRE("(<[^>]+) "$1 $2", html)
      html = exeRE("(<[^>]+) "$1 $2", html)
     Case "ONCLICK"   ' 去除样式style=""
      html = exeRE("(<[^>]+) "$1 $2", html)
      html = exeRE("(<[^>]+) "$1 $2", html)
     Case "ONDBCLICK"   ' 去除样式style=""
      html = exeRE("(<[^>]+) ondbclick=""[^""]*""([^>]*>)", "$1 $2", html)
      html = exeRE("(<[^>]+) ondbclick='[^']*'([^>]*>)", "$1 $2", html)

    End Select
   Next
   'html = Replace(html,"   'html = Replace(html,"   'html = Replace(html,"   DecodeFilter = html
End Function
   '用于将介绍信息中的链接转成在新窗口打开 2006-12-17 12:30 Add By Lingye
   Function ChangeURLTarget(inputhtml,targetname)
     inputhtml=exeRE("(<[^>]+)(href='[^']*')([^>]*>.+?)","     inputhtml=exeRE("(<[^>]+)(href=""[^""]*"")([^>]*>.+?)","     inputhtml=exeRE("(<[^>]+)(href=[\S]+?)([\s][^>]*>.+?)","     ChangeURLTarget=inputhtml
   End Function

'正则替换。。。
Public Function exeRE(re, rp, content)
   Set oReg = New RegExp
   oReg.IgnoreCase =True
   oReg.Global=True
   oReg.Pattern=re
   r = oReg.Replace(content,rp)
   Set oReg = Nothing
   exeRE = r
End Function

'取得回复状态。。。
Public Function Get_RevertState()
Response.Write("

"&Conn.execute("Select Count(User_ID) From WoWo_User")(0)&" "&Web_UserCName&"提供了"&Conn.Execute("Select Count(Re_ID) From WoWo_SrcRevert")(0)&" 个网站评论!

")
End Function

'取得RSS
Public Sub Get_Rss
Response.Write("

"&vbcr)
         Response.Write(""&vbcr)
           Response.Write(""&vbcr)
         Response.Write(""&vbcr)
       Response.Write("

用RSS阅读全站

"&vbcr)
End Sub

'取得GMail状态。。。
Public Function Get_GmailState()
Response.Write(""&Conn.execute("Select Count(User_ID) From WoWo_User")(0)&" "&Web_UserCName&"提供了"&Conn.Execute("Select Count(Gmail_ID) From WoWo_SrcGmail")(0)&" 个八卦!")
End Function

'取得全网址。。。
Public Function GetUrl2()
   Dim strTemp
   If LCase(Request.ServerVariables("HTTPS")) = "off" Then
    strTemp = "http://"
   Else
    strTemp = "https://"
   End If
   strTemp = strTemp & Request.ServerVariables("SERVER_NAME")
   If Request.ServerVariables("SERVER_PORT") <> 80 Then strTemp = strTemp & ":" & Request.ServerVariables("SERVER_PORT")
   strTemp = strTemp & Request.ServerVariables("URL")
   if Request.QueryString<> "" then
    strTemp = strTemp & "?" & Request.QueryString
   end if
   GetUrl2 = strTemp
End Function

'显示标签。。。
Public Function Get_TagsList(num,rowCount,num2,type1,type2)
   Set Rs_tags = Server.CreateObject("adodb.recordset")
   if type2 = "SYS" then
    Sql = "SELECT wowo_srctags.srctag_tagid, Count(WoWo_SrcTags.SrcTag_id) AS Tag_Count,(select tag_name from wowo_tags where tag_id=wowo_srctags.srctag_tagid) as tag_name FROM WoWo_SrcTags where wowo_srctags.srctag_ttype=true GROUP BY wowo_srctags.srctag_tagid Order By Count(WoWo_SrcTags.SrcTag_id) Desc"
   else
    Sql = "SELECT wowo_srctags.srctag_name, Count(WoWo_SrcTags.SrcTag_id) AS Tag_Count FROM WoWo_SrcTags where wowo_srctags.srctag_ttype=false and wowo_srctags.srctag_name<>'' GROUP BY wowo_srctags.srctag_name Order By Count(WoWo_SrcTags.SrcTag_id) Desc"
   end if
   Rs_tags.open Sql,conn,1,2
   tagsList_I = 0
   While not Rs_tags.Eof and tagsList_I < num
    tagsList_I = tagsList_I + 1
    if type2 = "SYS" then
     Response.Write("  * " & Server.HTMLEncode(Rs_tags("tag_name")) &"("&Rs_tags("Tag_Count")&")")
     if cint(rowCount) <> 0 then '固定标签才有换行显示
      if tagsList_I mod rowCount = 0 then Response.Write("
")
     end if
    else
     Response.Write(" * " & Server.HTMLEncode(Rs_tags("srctag_Name"))&"("&Rs_tags("Tag_Count")&")")
    end if
    Rs_tags.MoveNext
   Wend
   Rs_tags.close
   Set Rs_tags = nothing
End Function

'添加自定义标签
Public Function Add_NewTags(Src_ID,Tags_str)
   Sql_SrcTags = "Insert into WoWo_SrcTags(SrcTag_SrcID,SrcTag_Name,SrcTag_TType,SrcTag_IP)Values("&Src_ID&",'"&Tags_str&"',false,'"&Request.ServerVariables("REMOTE_ADDR")&"')"
   conn.execute(Sql_SrcTags)
End Function

'取得网址带http://。。。
Public Function Get_UrlStr(url)
   src_Url = lcase(url)
     if   left(src_Url,7) = "http://" then
    src_Url = right(src_Url,len(src_Url) - 7) '去掉 http://
     end if
     Src_Url_Arr = split(src_Url,"/")
     src_Url = Src_Url_Arr(0) '去掉第一个 / 以后的
     src_Url = "http://" & src_Url '再重新装上 http://

   Get_UrlStr = src_Url
End Function

'取得资源状态。。。
Public Function Get_SrcState()
   Get_SrcState = "有"&conn.ExeCute("SELECT count(User_ID) FROM WoWo_User")(0)&"个"&Web_UserCName&"，提供了"& Conn.Execute("SELECT count(Src_ID) FROM WoWo_Source WHERE Src_IsOver=False")(0) &"个资源信息，分享了"&Conn.Execute("SELECT count(Re_ID) FROM WoWo_SrcRevert")(0)&"条资源评论！"
End Function

'取得文章条数和用户个数的标题。。。
Public Function Get_SrcRecordCount
   Temp_Str = "有"& Conn.Execute("SELECT count(User_ID) FROM WoWo_User")(0) &"个"&Web_UserCName&"，"
   Temp_Str = Temp_Str & "提供了"& Conn.Execute("SELECT count(Src_ID) FROM WoWo_Source WHERE Src_IsOver=False")(0) &"个资源，"
   Temp_Str = Temp_Str & "分享了"&Conn.Execute("SELECT Count(Re_ID) FROM WoWo_SrcRevert")(0)&"条资源评论！"
   Get_SrcRecordCount = Temp_Str
End Function

'取得文章标签。。。
Public Function Get_SrcTags(Src_ID)
   Set Rs_Tags2 = Server.CreateObject("Adodb.recordset")
   Sql_Tag2 = "Select SrcTag_ID,SrcTag_Name from WoWo_SrcTags Where SrcTag_SrcID="&Src_ID&" and srctag_ttype=false"
   Rs_Tags2.open Sql_Tag2,conn
   while not Rs_Tags2.eof
    Src_Tags_2 = Src_Tags_2 & "" & Rs_Tags2("SrcTag_Name") &" "
    Rs_Tags2.MoveNext
   wend
   Rs_Tags2.Close
   Sql_Tag2 = "Select WoWo_SrcTags.SrcTag_ID,WoWo_Tags.tag_ID,WoWo_Tags.tag_Name from WoWo_SrcTags inner join WoWo_Tags on WoWo_SrcTags.SrcTag_TagID=WoWo_Tags.tag_ID Where WoWo_SrcTags.SrcTag_SrcID="&Src_ID&" and srctag_ttype=true"
   Rs_Tags2.open Sql_Tag2,conn
   while not Rs_Tags2.eof
    Src_Tags_2 = Src_Tags_2 & "" & Rs_Tags2("tag_Name") &" "
    Rs_Tags2.MoveNext
   wend
   Rs_Tags2.Close
   Set Rs_Tags2 = nothing
   if Src_Tags_2 <> "" then
    Get_SrcTags = Src_Tags_2
   else
    Get_SrcTags = "无标签"
   end if
End Function

'是否已顶。。
Public Function Is_Hit(Src_ID)
   Temp_HitStr = ""
   if Session("_WUserID") = "" then
    Temp_HitStr = "顶一下"
   else

            Set Temp1   = conn.execute("Select Src_ID From WoWo_Source Where Src_ID="&Src_ID&" and Src_UserID="&Session("_WUserID"))
            If not Temp1.eof then
               Is_Hit=true
            Temp1.close
            set Temp1=nothing
            end if

   Set Temp2   = conn.execute("Select Hit_ID From WoWo_SrcHit Where Hit_SrcID="&Src_ID&" and Hit_UserID="&Session("_WUserID"))
         If not Temp2.eof then
          Is_Hit=true
           Temp2.close
           set Temp2=nothing
          end if

    If Is_Hit=true   then
    Temp_HitStr = "已顶"
    else
     Temp_HitStr = "顶一下"
    end if

end if
Is_Hit = Temp_HitStr
End Function

'我顶。。。。。
Public Function Set_Hit(src_ID)
   if Session("_WUserID") = "" then '判断是否登入
    Response.Write("顶一下")
   else
    Is_Hit_Temp = Conn.Execute("Select Count(Hit_ID) From WoWo_SrcHit Where Hit_SrcID="&Src_ID&" and Hit_UserID="&Session("_WUserID"))(0)

    if Is_Hit_Temp <= 0 then '判断是否顶完(避免开多个窗口的问题)
     Sql_Hit = "Insert into WoWo_SrcHit(Hit_SrcID,Hit_UserID,Hit_Time,Hit_IP)"
     Sql_Hit = Sql_Hit & "Values(" & src_id & ",'" & Session("_WUserID") & "','" & Now() & "','" & Request.ServerVariables("REMOTE_ADDR") & "')"
     Conn.Execute(Sql_Hit)
     Conn.Execute("Update WoWo_Source Set Src_HitNum=Src_HitNum+1,Src_HitUpdate='"&Now()&"' Where Src_ID="&src_id)
     response.redirect request.querystring("HitBackUrl")
     response.end
    else
     Response.Write("已顶")
    end if
   end if

End Function

'直接取得大类列表。。。
Public Function Get_SrcType(sel_id)
   Set Rs_SrcType = Conn.Execute("Select * from WoWo_SrcType Where Type_IsUse=true Order By Type_OrderBy")
   While Not Rs_SrcType.Eof
    selected = ""
    if cint(Rs_SrcType("Type_ID")) = cint(sel_id) then
     selected = " selected"
    end if
    Response.Write("")
    Rs_SrcType.MoveNext
   Wend
   Rs_SrcType.Close
   Set Rs_SrcType = Nothing
End Function

'直接取得小类列表。。。。
Public Function Get_SrcChild(sel_id)
   Set Rs_SrcChild = Conn.Execute("Select * from WoWo_SrcChild Where Child_IsUse=true Order By Child_OrderBy")
   While Not Rs_SrcChild.Eof
    selected = ""
    if cint(Rs_SrcChild("Child_ID")) = cint(sel_id) then
     selected = " selected"
    end if
    Response.Write("")
    Rs_SrcChild.MoveNext
   Wend
   Rs_SrcChild.Close
   Set Rs_SrcChild = Nothing
End Function

'取得小类列表(大类的ID)。。。。
Public Function Get_SrcChild2(Type_ID,sel_id)
   Set Rs_SrcChild = Conn.Execute("Select * from WoWo_SrcChild Where Child_IsUse=true and Child_TypeID="&Type_ID&" Order By Child_OrderBy")
   While Not Rs_SrcChild.Eof
    selected = ""
    if cint(Rs_SrcChild("Child_ID")) = cint(sel_id) then
     selected = " selected"
    end if
    Response.Write("")
    Rs_SrcChild.MoveNext
   Wend
   Rs_SrcChild.Close
   Set Rs_SrcChild = Nothing
End Function
Public Function Get_Line
   Response.Write("

")
Response.Write("")
Response.Write("

")
End Function
Public Sub Get_SrcSearch
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write("

找资源

"&Vbcr)
Response.Write("

"&Vbcr)
Response.Write(""&Vbcr)
Response.Write("

"&Vbcr)
Response.Write("

"&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write(""&Vbcr)
   Response.Write("

"&WoDig.Get_SrcState()&"

"&Vbcr)
End Sub


'==================================================系统函数==================================
Public Function SendMail(MailtoAddress,MailtoName,Subject,MailBody,Priority)
   MailServerUserName = Web_EmailUserName
   MailServerPassword = Web_EmailUserPass
   MailDomain = Web_EmailUserName
   MailServer = Web_EmailServer
   FromName = Web_Name
   MailFrom = Web_EmailUserName

   on error resume next
   Dim JMail
   Set JMail=Server.CreateObject("JMail.Message")
   if err then
    SendMail= "

没有安装JMail组件

"
    err.clear
    exit function
   end if
   JMail.Charset = "gb2312"
   JMail.silent = true
   JMail.ContentType = "text/html"
   JMail.MailServerUserName = MailServerUserName
   JMail.MailServerPassWord = MailServerPassword
   JMail.MailDomain = MailDomain
   JMail.AddRecipient MailtoAddress,MailtoName
   JMail.Subject = Subject
   'JMail.HMTLBody = MailBody        '邮件正文（HTML格式）
   JMail.Body   = MailBody
   JMail.FromName = FromName
   JMail.From    = MailFrom
   JMail.Priority = Priority
   JMail.Send(MailServer)
   SendMail    = JMail.ErrorMessage
   JMail.Close
   Set JMail   = nothing
End Function

'提示。。
Public Function MsgBox2(HintText,HintType,GoWhere)
   Dim Hint,HintTypeText
   Select Case HintType
    Case "0"
     Hint=16
     HintTypeText="出错啦！"
    Case "1"
     Hint=48
     HintTypeText="警告!"
    Case "2"
     Hint=64
     HintTypeText="提示!"
   End Select
   Response.Write ""
   if GoWhere<>"" then
    if GoWhere = "0" then
     Response.Write ""
    else
     Response.Write ""
    end if
   end if
   Response.End()
End Function

'创建一个KEY。。。
Public Function Pub_Createpass()
   Dim Ran,i,LengthNum
   LengthNum=16
   Createpass=""
   For i=1 To LengthNum
    Randomize
    Ran = CInt(Rnd * 2)
    Randomize
    If Ran = 0 Then
     Ran = CInt(Rnd * 25) + 97
     Pub_Createpass = Pub_Createpass& UCase(Chr(Ran))
    ElseIf Ran = 1 Then
     Ran = CInt(Rnd * 9)
     Pub_Createpass = Pub_Createpass & Ran
    ElseIf Ran = 2 Then
     Ran = CInt(Rnd * 25) + 97
     Pub_Createpass = Pub_Createpass& Chr(Ran)
    End If
   Next
End Function

'设置图片。。
Public Function Pub_SetImgWH(IMGPath,MaxW,MaxH)
'
   Set PP = New ImgWHInfo
   W = PP.imgW(lcase(Server.Mappath(IMGPath)))
   H = PP.imgH(lcase(Server.Mappath(IMGPath)))
   Set pp = Nothing
   if W>MaxW then
    H=H*MaxW/W
    W=MaxW
   end if
   if H >MaxH then
    W=W*MaxH/H
    H=MaxH
   end if
   Pub_SetImgWH = "src='"&IMGPath&"' width='"&int(W)&"' height='"&int(H)&"'   "
End Function

'删除文件。。。。
Public Sub DelFiles(delfilesname,filespath)
   Dim FileDelete,files,strFileFullPath,filesNum
   If Right(filespath,1)<>"\" Then filespath = filespath & "\"
   If delfilesname<>"" And Not IsNull(delfilesname) Then
    Set FileDelete = CreateObject("Scripting.FileSystemObject")
    files = Split(delfilesname & "|","|")
    For filesNum=0 to Ubound(files)-1
     strFileFullPath = filespath + files(filesNum)
     If FileDelete.FileExists(strFileFullPath) Then FileDelete.DeleteFile(strFileFullPath)
    Next
   End If
End Sub

'检测输入。。。
Public Function Checkin(s)
   s = trim(s)
   s = replace(s," "," ")
   s = replace(s,"'","'")
   s = replace(s,"""",""")
   s = replace(s,"<","<")
   s = replace(s,">",">")
   Checkin=s
End Function

Public Function CreateMultiFolder(ByVal CFolder)
   Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
   Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
   BlInfo = False
   CreateFolder = CFolder
   On Error Resume Next
   Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
   If Err Then
    Err.Clear()
    Exit Function
   End If
   CreateFolder = Replace(CreateFolder,"\","/")
   If Right(CreateFolder,1)="/" Then
    CreateFolder = Left(CreateFolder,Len(CreateFolder)-1)
   End If
   CreateFolderArray = Split(CreateFolder,"/")
   For i = 0 to UBound(CreateFolderArray)
    CreateFolderSub = ""
    For ii = 0 to i
     CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
    Next
    PhCreateFolderSub = Server.MapPath(CreateFolderSub)
    If Not objFSO.FolderExists(PhCreateFolderSub) Then
     objFSO.CreateFolder(PhCreateFolderSub)
    End If
   Next
   If Err Then
    Err.Clear()
   Else
    BlInfo = True
   End If
   Set objFSO=nothing
   CreateMultiFolder = BlInfo
End Function
End Class
%>

网站栏目：去除HTML里的标签
本文来源：http://scyanting.com/article/goceso.html

去除HTML里的标签

其他资讯