<% 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("
用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.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("
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 %>
