去除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("</?script[^>]*>", "", html)
      html = exeRE("on(mouse|exit|error|click|key)", "", html)
     Case "TABLE":   ' 去除表格<table><tr><td><th>
      html = exeRE("</?table[^>]*>", "", html)
      html = exeRE("</?tr[^>]*>", "", html)
      html = exeRE("</?th[^>]*>", "", html)
      html = exeRE("</?td[^>]*>", "", html)
      html = exeRE("</?tbody[^>]*>", "", html)
     Case "CLASS"   ' 去除样式类class=""
      html = exeRE("(<[^>]+) class=[^ |^>]*([^>]*>)", "$1 $2", html)
     Case "STYLE"   ' 去除样式
      html = exeRE("(<[^>]+) [^""]*""([^>]*>)", "$1 $2", html)
      html = exeRE("(<[^>]+) style='[^']*'([^>]*>)", "$1 $2", html)
     Case "IMG"   ' 去除样式
      html = exeRE("</?img[^>]*>", "", html)
     Case "XML"   ' 去除XML<?xml>
      html = exeRE("<[^>]*>", "", html)
     Case "NAMESPACE" ' 去除命名空间<o:p></o:p>
      html = exeRE("<\/?[a-z]+:[^>]*>", "", html)
     Case "FONT"   ' 去除字体<font></font>
      html = exeRE("</?font[^>]*>", "", html)
     Case "MARQUEE"   ' 去除字幕<marquee></marquee>
      html = exeRE("</?marquee[^>]*>", "", html)
     Case "OBJECT"   ' 去除对象<object><param><embed></object>
      html = exeRE("</?object[^>]*>", "", html)
      html = exeRE("</?param[^>]*>", "", html)
      'html = exeRE("</?embed[^>]*>", "", html)
     Case "EMBED"
        html =   exeRE("</?embed[^>]*>", "", html)
     Case "DIV"   ' 去除对象<object><param><embed></object>
      html = exeRE("</?div([^>])*>", "$1", html)
     Case "ONLOAD"   ' 去除样式
      html = exeRE("(<[^>]+) "$1 $2", html)
      html = exeRE("(<[^>]+) "$1 $2", html)
     Case "ONCLICK"   ' 去除样式
      html = exeRE("(<[^>]+) "$1 $2", html)
      html = exeRE("(<[^>]+) "$1 $2", html)
     Case "ONDBCLICK"   ' 去除样式
      html = exeRE("(<[^>]+) ondbclick=""[^""]*""([^>]*>)", "$1 $2", html)
      html = exeRE("(<[^>]+) ondbclick='[^']*'([^>]*>)", "$1 $2", html)

    End Select
   Next
   'html = Replace(html,"<table","<")
   'html = Replace(html,"<tr","<")
   'html = Replace(html,"<td","<")
   DecodeFilter = html
End Function
   '用于将介绍信息中的链接转成在新窗口打开 2006-12-17 12:30 Add By Lingye
   Function ChangeURLTarget(inputhtml,targetname)
     inputhtml=exeRE("(<[^>]+)(href='[^']*')([^>]*>.+?</a>)","<a $2"&chr(13)&"target="""&targetname&"""$3",inputhtml)
     inputhtml=exeRE("(<[^>]+)(href=""[^""]*"")([^>]*>.+?</a>)","<a $2"&chr(13)&"target="""&targetname&"""$3",inputhtml)
     inputhtml=exeRE("(<[^>]+)(href=[\S]+?)([\s][^>]*>.+?</a>)","<a $2"&chr(13)&"target="""&targetname&"""$3",inputhtml)
     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("<div align='center'><span class='hot2'>"&Conn.execute("Select Count(User_ID) From WoWo_User")(0)&"</span> "&Web_UserCName&"提供了<span class='hot2'>"&Conn.Execute("Select Count(Re_ID) From WoWo_SrcRevert")(0)&"</span> 个网站评论!</div>")
End Function

'取得RSS
Public Sub Get_Rss
    Response.Write("<table width='96%' height='21'   border='0' align='center' cellpadding='0' cellspacing='0'>"&vbcr)
         Response.Write("<tr>"&vbcr)
           Response.Write("<td height='30' class='mn'> <div align='right'><span class='green'>用RSS阅读全站 <script type=""text/javascript"">document.write('<a href=""'+getRssUrl()+'"" target=""_blank""><img src=""Images/rss.gif"" width=""35"" height=""12"" border=""0"" /></a>')</script></span></div></td>"&vbcr)
         Response.Write("</tr>"&vbcr)
       Response.Write("</table>"&vbcr)
End Sub

'取得GMail状态。。。
Public Function Get_GmailState()
   Response.Write("<span class='hot2'>"&Conn.execute("Select Count(User_ID) From WoWo_User")(0)&"</span> "&Web_UserCName&"提供了<span class='hot2'>"&Conn.Execute("Select Count(Gmail_ID) From WoWo_SrcGmail")(0)&"</span> 个八卦!")
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("  * <a href='Default.asp?Tags_ID="&Rs_tags("srctag_tagid")&"'>" & Server.HTMLEncode(Rs_tags("tag_name")) &"("&Rs_tags("Tag_Count")&")</a>")
     if cint(rowCount) <> 0 then '固定标签才有换行显示
      if tagsList_I mod rowCount = 0 then Response.Write("<br>")
     end if
    else
     Response.Write(" * <a href='Default.asp?Tags_Name="&trim(Rs_tags("srctag_Name"))&"'>" & Server.HTMLEncode(Rs_tags("srctag_Name"))&"("&Rs_tags("Tag_Count")&")</a>")
    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 = "有<span class='hot2'>"&conn.ExeCute("SELECT count(User_ID) FROM WoWo_User")(0)&"</span>个"&Web_UserCName&"，提供了<span class='hot2'>"& Conn.Execute("SELECT count(Src_ID) FROM WoWo_Source WHERE Src_IsOver=False")(0) &"</span>个资源信息，分享了<span class='hot2'>"&Conn.Execute("SELECT count(Re_ID) FROM WoWo_SrcRevert")(0)&"</span>条资源评论！"
End Function

'取得文章条数和用户个数的标题。。。
Public Function Get_SrcRecordCount
   Temp_Str = "有<span class='hot2'>"& Conn.Execute("SELECT count(User_ID) FROM WoWo_User")(0) &"</span>个"&Web_UserCName&"，"
   Temp_Str = Temp_Str & "提供了<span class='hot2'>"& Conn.Execute("SELECT count(Src_ID) FROM WoWo_Source WHERE Src_IsOver=False")(0) &"</span>个资源，"
   Temp_Str = Temp_Str & "分享了<span class='hot2'>"&Conn.Execute("SELECT Count(Re_ID) FROM WoWo_SrcRevert")(0)&"</span>条资源评论！"
   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 & "<a href='Default.asp?tags_Name=" & Rs_Tags2("SrcTag_Name") & "'>" & Rs_Tags2("SrcTag_Name") &"</a> "
    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 & "<a href='Default.asp?tags_ID=" & Rs_Tags2("tag_ID") & "'>" & Rs_Tags2("tag_Name") &"</a> "
    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 = "<a href='javascript:Hit("&Src_ID&")' onMouseOver='window.status=""我顶！"";return true;'>顶一下</a>"
   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 = "<a href='javascript:Hit("&Src_ID&")' onMouseOver='window.status=""我顶！"";return true;'>顶一下</a>"
    end if

end if
Is_Hit = Temp_HitStr
End Function

'我顶。。。。。
Public Function Set_Hit(src_ID)
   if Session("_WUserID") = "" then '判断是否登入
    Response.Write("<a href='Login.asp'>顶一下</a>")
   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("<Option "&selected&" Value='"&Rs_SrcType("Type_ID")&"'>"&Rs_SrcType("Type_Name")&"</Option>")
    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("<Option "&selected&" Value='"&Rs_SrcChild("Child_ID")&"'>"&Rs_SrcChild("Child_Name")&"</Option>")
    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("<Option "&selected&" Value='"&Rs_SrcChild("Child_ID")&"'>"&Rs_SrcChild("Child_Name")&"</Option>")
    Rs_SrcChild.MoveNext
   Wend
   Rs_SrcChild.Close
   Set Rs_SrcChild = Nothing
End Function
Public Function Get_Line
   Response.Write("<table width='98%' height='1'   border='0' align='center' cellpadding='0' cellspacing='0'>")
          Response.Write("<tr><td height=""4""></td></tr><tr><td background='Images/dot.jpg'></td></tr><tr><td height=""5""></td></tr>")
         Response.Write("</table>")
End Function
Public Sub Get_SrcSearch
   Response.Write("<table width='98%'   border='0' align='center' cellpadding='0' cellspacing='3'>"&Vbcr)
   Response.Write("<form action='Default.asp' method='post' name='frm_data'>"&Vbcr)
   Response.Write("<tr><td height='25' class='attn'><div align='center'>找资源</div></td></tr>"&Vbcr)
   Response.Write("<tr>"&Vbcr)
   Response.Write("<td height='25'>"&Vbcr)
   Response.Write("<div align='center'>"&Vbcr)
   Response.Write("<input type='text' name='S_Havving' />"&Vbcr)
   Response.Write("</div></td>"&Vbcr)
   Response.Write("</tr>"&Vbcr)
   Response.Write("<tr>"&Vbcr)
   Response.Write("<td height='25'>"&Vbcr)
   Response.Write("<div align='center'>"&Vbcr)
   Response.Write("<input type='submit' name='Submit2' value='我要搜索' />"&Vbcr)
   Response.Write("<input type='hidden' name='Src_Type' value='"&Src_Type&"' />"&Vbcr)
   Response.Write("</div></td>"&Vbcr)
   Response.Write("</tr>"&Vbcr)
   Response.Write("<tr>"&Vbcr)
   Response.Write("<td height='25'><div align='center'>"&WoDig.Get_SrcState()&"</div></td>"&Vbcr)
   Response.Write("</tr>"&Vbcr)
   Response.Write("</form>"&Vbcr)
   Response.Write("</table>"&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= "<br><li>没有安装JMail组件</li>"
    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 "<Script Language=VBScript>"
   Response.Write "MsgBox """ & Replace(HintText,"'","") &_
    """," & Hint & ",""" & HintTypeText & """ "
   Response.Write "</Script>"
   if GoWhere<>"" then
    if GoWhere = "0" then
     Response.Write "<Script Language=JavaScript>history.back();</Script>"
    else
     Response.Write "<Script Language=JavaScript>location.href='" & GoWhere & "';</Script>"
    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," ","&nbsp;")
   s = replace(s,"'","&#39;")
   s = replace(s,"""","&quot;")
   s = replace(s,"<","&lt;")
   s = replace(s,">","&gt;")
   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
%>