网站建设资讯

NEWS

网站建设资讯

去除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," ","&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
    %>


    分享文章:去除HTML里的标签
    文章源于:http://njwzjz.com/article/goceso.html