隐藏html里的url,去除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":   ' 去除表格

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" ' 去除命名空间 html = exeRE("]*>", "", html) Case "FONT"   ' 去除字体 html = exeRE("?font[^>]*>", "", html) Case "MARQUEE"   ' 去除字幕 html = exeRE("?marquee[^>]*>", "", html) Case "OBJECT"   ' 去除对象 html = exeRE("?object[^>]*>", "", html) html = exeRE("?param[^>]*>", "", html) 'html = exeRE("?embed[^>]*>", "", html) Case "EMBED" html =   exeRE("?embed[^>]*>", "", html) Case "DIV"   ' 去除对象 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," '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("

Response.Write("

"&vbcr)

           Response.Write("

用RSS阅读全站 

"&vbcr)

Response.Write("

"&vbcr)

Response.Write("

"&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("Type_Name")&"")

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("Child_Name")&"")

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("Child_Name")&"")

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("

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)

Response.Write("

"&Vbcr)

Response.Write("

"&Vbcr)

Response.Write("

"&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 "

Response.Write "MsgBox """ & Replace(HintText,"'","") &_

"""," & Hint & ",""" & HintTypeText & """ "

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

%>