gusucode.com > 爱美尔女性商城源码 1.0源码程序 > wen/Inc/Function.asp
<%
'****************************************************
' 老Y文章管理系统 Power by laoy8.net
' Web: http://www.laoy8.net
' Copyright (C) 2008-2009 laoy8.net All Rights Reserved.
'****************************************************
Function Mydb(MySqlstr,MyDBType)
Select Case MyDBType
Case 0 : Conn.Execute(MySqlstr) : Dataquery = Dataquery + 1
Case 1 : Set Mydb = Conn.Execute(MySqlstr) : Dataquery = Dataquery + 1
Case 2 : Set Mydb = Server.CreateObject("Adodb.Recordset") : Mydb.Open MySqlstr,Conn,1,1 : Dataquery = Dataquery + 1
case 3:
set db = server.createobject("Adodb.Recordset")
db.open sqlstr, conn, 1, 3
End Select
End Function
Function CheckStr(str)
CheckStr=replace(replace(replace(replace(str,"<","<"),">",">"),chr(13),"")," ","")
CheckStr=replace(replace(replace(replace(CheckStr,"'",""),"and",""),"insert",""),"set","")
CheckStr=replace(replace(replace(replace(CheckStr,"select",""),"update",""),"delete",""),chr(34),"")
CheckStr=replace(replace(replace(replace(CheckStr,"*",""),"=",""),"mid",""),"count","")
CheckStr=replace(replace(replace(replace(CheckStr,"%",""),",",""),"union",""),"where","")
CheckStr=replace(replace(replace(replace(replace(CheckStr,"(",""),")",""),Chr(0),""),"+",""),";","")
end Function
Function LaoYRequest(ParaName)
Dim ParaValue
ParaValue = trim(ParaName)
If ParaValue="" Then Exit Function
If Not isNumeric(ParaValue) Then
Response.Write "<li> 参数类型不合法"
Response.end
Else
LaoYRequest = ParaValue
End If
End Function
Function GetIP()
Dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
getIP = Checkstr(Trim(Mid(strIPAddr, 1, 30)))
If getIP="" then getIP="127.0.0.1"
End Function
Function ShowLabel(id)
if id = "" or isnull(id) then
ShowLabel = 0
else
Sqld = "Select Content from "&tbname&"_Label where ID = " & id
Set rsd = conn.execute(Sqld)
if not rsd.eof then
ShowLabel = rsd(0)
else
ShowLabel = ""
end if
rsd.close
end if
End function
Function LoseHtml(ContentStr)
Dim ClsTempLoseStr,regEx
ClsTempLoseStr = Cstr(ContentStr)
Set regEx = New RegExp
regEx.Pattern = "<(.[^>]*)>"
regEx.IgnoreCase = True
regEx.Global = True
ClsTempLoseStr = regEx.Replace(ClsTempLoseStr,"")
RegEx.Pattern = "(&.+?;)"
ClsTempLoseStr = RegEx.Replace(ClsTempLoseStr, "")
ClsTempLoseStr = Replace(ClsTempLoseStr,VbCrlf,"")
ClsTempLoseStr = Replace(ClsTempLoseStr,VbCr,"")
ClsTempLoseStr = Replace(ClsTempLoseStr,VbLf,"")
ClsTempLoseStr = Replace(ClsTempLoseStr," ","")
ClsTempLoseStr = Replace(ClsTempLoseStr,"","")
ClsTempLoseStr = Replace(ClsTempLoseStr,"""","'")
ClsTempLoseStr = Replace(ClsTempLoseStr,"[code]","")
ClsTempLoseStr = Replace(ClsTempLoseStr,"<!--","")
ClsTempLoseStr = Trim(ClsTempLoseStr)
LoseHtml = ClsTempLoseStr
End Function
Function dvHTMLEncode(fString)
if not isnull(fString) then
fString = replace(fString, ">", ">")
fString = replace(fString, "<", "<")
fString = Replace(fString, CHR(32), " ")
fString = Replace(fString, CHR(9), " ")
fString = Replace(fString, CHR(34), """)
fString = Replace(fString, CHR(39), "'")
fString = Replace(fString, CHR(13), "")
fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
fString = Replace(fString, CHR(10), "<BR> ")
'fString = Replace(fString, "http://static3.photo.sina.com.cn", "photo.asp?url=http://static3.photo.sina.com.cn")
dvHTMLEncode = fString
end if
end Function
Function HasChinese(str)
HasChinese = false
dim i
for i=1 to Len(str)
if Asc(Mid(str,i,1)) < 0 then
HasChinese = true
exit for
end if
next
end Function
Function replacecolor(Str)
Dim re,s
S=Str
Set re=new RegExp
re.IgnoreCase =True
re.Global=True
re.Pattern="("& KeyWord &")"
s=re.Replace(s,"<font color='red'>"& KeyWord &"</font>")
Set Re=Nothing
replacecolor=s
End Function
Function iparray(ipstr)
dim t,ipx,ipfb
if not isnull(ipstr) then
t = 0
ipx=""
ipfb = split(ipstr, ".",4)
for t = 0 to 2
ipx = ipx&ipfb(t)&"."
next
iparray = ipx&"*"
end if
end Function
'判断数字奇偶
Function isEven(num)
if not isNumeric(num) then
isEven="这不是一个数字啊"
exit Function
end if
if num mod 2 = 0 then
isEven=0
else
isEven=1
end if
end Function
Function FormatDate(DateAndTime,para)
On Error Resume Next
Dim y, m, d, h, mi, s, strDateTime
FormatDate = DateAndTime
If Not IsNumeric(para) Then Exit Function
If Not IsDate(DateAndTime) Then Exit Function
y = Mid(CStr(Year(DateAndTime)),3)
m = CStr(Month(DateAndTime))
If Len(m) = 1 Then m = "0" & m
d = CStr(Day(DateAndTime))
If Len(d) = 1 Then d = "0" & d
h = CStr(Hour(DateAndTime))
If Len(h) = 1 Then h = "0" & h
mi = CStr(Minute(DateAndTime))
If Len(mi) = 1 Then mi = "0" & mi
s = CStr(Second(DateAndTime))
If Len(s) = 1 Then s = "0" & s
Select Case para
Case "1"
strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
Case "2"
strDateTime = y & "-" & m & "-" & d
Case "3"
strDateTime = y & "/" & m & "/" & d
Case "4"
strDateTime = y & "年" & m & "月" & d & "日"
Case "5"
strDateTime = m & "-" & d
Case "6"
strDateTime = m & "/" & d
Case "7"
strDateTime = m & "月" & d & "日"
Case "8"
strDateTime = y & "年" & m & "月"
Case "9"
strDateTime = y & "-" & m
Case "10"
strDateTime = y & "/" & m
Case "11"
y = CStr(Year(DateAndTime))
strDateTime = y & "-" & m & "-" & d
Case "12"
y = CStr(Year(DateAndTime))
strDateTime = y & m & d & "_" & h & mi & s
Case Else
strDateTime = DateAndTime
End Select
'FormatDate = strDateTime
If datediff("d",DateAndTime,Now())=0 then
FormatDate = "<font color=#ff0000>"&strDateTime&"</font>"
else
FormatDate = ""&strDateTime&""
End if
End Function
'=================================================
'过程名：BbbImg
'作 用：鼠标滚轮控制图片大小的函数
'参 数：strText
'=================================================
Function BbbImg(strText)
Dim s,re
Set re=New RegExp
re.IgnoreCase = true
re.Global = true
s=strText
'去掉图片中的脚本代码
re.Pattern="<IMG.[^>]*SRC(=| )(.[^>]*)>"
If mouserimg=1 then
s=re.replace(s,"<p style=""text-align:center;""><IMG SRC=$2 onload=""javascript:resizeimg(this,575,600)""></p>")
else
s=re.replace(s,"<p style=""text-align:center;""><IMG SRC=$2></p>")
End if
BbbImg = ChkBadWords(s)
Set re=Nothing
End Function
'脏话过滤
Function ChkBadWords(Str)
If IsNull(Str) Then Exit Function
On Error Resume Next
Dim i,rBadWord,BadWord
BadWord = BadWord1
BadWord = Split(BadWord,"|||")
For i = 0 To Ubound(BadWord)
rBadWord = Split(BadWord(i),"=")
Str = Replace(Str,rBadWord(0),rBadWord(1))
Next
ChkBadWords = Str
End Function
'用户名检测
Function ChkRegName(str)
ChkRegName = True
On Error Resume Next
For i=0 To Ubound(Split(userWord,","))
If Instr(Str,Split(userWord,",")(i)) > 0 Then
ChkRegName = False
Exit Function
End If
Next
End Function
'# IIF
Function IIF(A,B,C)
If A Then IIF = B Else IIF = C
End Function
Function laoy(block)
if not isnull(block) then
block = Replace(block, "{$SitePath}", SitePath)
laoy = block
end if
End Function
'搜索蜘蛛
Function spiderbot()
dim agent
agent = lcase(request.servervariables("http_user_agent"))
dim Bot: Bot = ""
'百度
if instr(agent, "baiduspider") > 0 then Bot = "百度"
if instr(agent, "baiducustomer") > 0 then Bot = "百度"
if instr(agent, "baidu-thumbnail") > 0 then Bot = "百度"
if instr(agent, "baiduspider-mobile-gate") > 0 then Bot = "百度"
if instr(agent, "baidu-transcoder/1.0.6.0") > 0 then Bot = "百度"
'谷歌google
if instr(agent, "googlebot/2.1") > 0 then Bot = "谷歌"
if instr(agent, "googlebot-image/1.0") > 0 then Bot = "谷歌"
if instr(agent, "feedfetcher-google") > 0 then Bot = "谷歌"
if instr(agent, "mediapartners-google") > 0 then Bot = "谷歌"
if instr(agent, "adsbot-google") > 0 then Bot = "谷歌"
if instr(agent, "googlebot-mobile/2.1") > 0 then Bot = "谷歌"
if instr(agent, "googlefriendconnect/1.0") > 0 then Bot = "谷歌"
'雅虎yahoo
if instr(agent, "yahoo! slurp;") > 0 then Bot = "雅虎"
if instr(agent, "yahoo! slurp/3.0") > 0 then Bot = "雅虎"
if instr(agent, "yahoo! slurp china") > 0 then Bot = "雅虎"
if instr(agent, "yahoofeedseeker/2.0") > 0 then Bot = "雅虎"
if instr(agent, "yahoo-blogs") > 0 then Bot = "雅虎"
if instr(agent, "yahoo-mmcrawler") > 0 then Bot = "雅虎"
if instr(agent, "yahoo contentmatch crawler") > 0 then Bot = "雅虎"
'微软bing
if instr(agent, "msnbot/1.1") > 0 then Bot = "微软bing"
if instr(agent, "msnbot/2.0b") > 0 then Bot = "微软bing"
if instr(agent, "msrabot/2.0/1.0") > 0 then Bot = "微软bing"
if instr(agent, "msnbot-media/1.0") > 0 then Bot = "微软bing"
if instr(agent, "msnbot-products") > 0 then Bot = "微软bing"
if instr(agent, "msnbot-academic") > 0 then Bot = "微软bing"
if instr(agent, "msnbot-newsblogs") > 0 then Bot = "微软bing"
'腾讯搜搜soso
if instr(agent, "sosospider") > 0 then Bot = "腾讯搜搜"
if instr(agent, "sosoblogspider") > 0 then Bot = "腾讯搜搜"
if instr(agent, "sosoimagespider") > 0 then Bot = "腾讯搜搜"
'网易有道
if instr(agent, "youdaobot/1.0") > 0 then Bot = "网易有道"
if instr(agent, "yodaobot-image/1.0") > 0 then Bot = "网易有道"
if instr(agent, "yodaobot-reader/1.0") > 0 then Bot = "网易有道"
'搜狐搜狗
if instr(agent, "sogou web robot") > 0 then Bot = "搜狗"
if instr(agent, "sogou web spider/3.0") > 0 then Bot = "搜狗"
if instr(agent, "sogou web spider/4.0") > 0 then Bot = "搜狗"
if instr(agent, "sogou head spider/3.0") > 0 then Bot = "搜狗"
if instr(agent, "sogou-test-spider/4.0") > 0 then Bot = "搜狗"
if instr(agent, "sogou orion spider/4.0") > 0 then Bot = "搜狗"
'Alexa
if instr(agent, "ia_archiver") > 0 then Bot = "Alexa"
if instr(agent, "iaarchiver") > 0 then Bot = "Alexa"
'奇虎
if instr(agent, "qihoo") > 0 then Bot = "Qihoo"
'ASK.com
if instr(agent, "ask jeeves/teoma") > 0 then Bot = "Ask Jeeves/Teoma"
if len(Bot) > 0 then
set rs = server.CreateObject ("adodb.recordset")
sql="select [Botname],[LastDate] From ["&tbname&"_Bots] Where [Botname]='" & Bot & "'"
rs.open sql,conn,1,3
if rs.eof and rs.bof then
rs.AddNew
rs(0) = Bot
rs(1) = now()
else
rs(1) = now()
end if
rs.update
rs.close: set rs = nothing
end if
end Function
Sub CreateDir(strPath)
Dim sTmp,i,Fso,sPath
sPath = replace(strPath,"/","\")
sPath=Split(sPath,"\")
Set fso = Server.CreateObject("Scripting.FileSystemObject")
For I=0 To Ubound(sPath)
sTmp=Replace(sTmp&sPath(I)&"\","\\","\")
If Not Fso.FolderExists(server.Mappath(sTmp)) Then
Fso.CreateFolder server.Mappath(sTmp)
End if
Next
Set Fso = nothing
End Sub
function createfile(byval content,byval filedir)
on error resume next
dim obj : set obj = server.createobject("adodb.Stream")
obj.type = 2
obj.open
obj.charset = "GB2312"
obj.position = obj.Size
obj.writeText = content
obj.savetofile server.mappath(filedir), 2
obj.close
if err then err.clear: createfile = false else createfile = true
set obj = nothing
End function
'显示相关文章
'P_ConID:数值型，当前文章ID
'P_Key:字符型，当前文章关健字
'P_Row:数值型，要显示相关文章的条数
'P_ICO:字符型，标题前图标，可以图片也可为字符
'P_Time:数值型，显示时间，０为不显示，否则为时间格式
Function ShowMutualityArticle(P_ConID,P_Key,P_Row,P_ICO,P_Time)
dim pRs,pSql
dim i,TempKeyWord
if P_Row > 0 then
pSql = "Select TOP "& P_Row
else
pSql = "Select "
end if
pSql = pSql & " ID,Title,ClassId,DateAndTime From ["&tbname&"_Article] Where ID <> "& P_ConID &" And "
if Instr(P_Key,"|") > 0 then
P_Key = Split(P_Key,"|")
TempKeyWord = TempKeyWord &"("
For i = 0 to Ubound(P_Key)
TempKeyWord = TempKeyWord &" KeyWord like '%"& P_Key(i) &"%' or KeyWord like '%|"& P_Key(i) &"|%' or KeyWord like '%"& P_Key(i) &"|%' or KeyWord like '%|"& P_Key(i) &"%' "
if i = Ubound(P_Key) then
TempKeyWord = TempKeyWord &") And "
else
TempKeyWord = TempKeyWord &" Or "
end if
Next
else
TempKeyWord = TempKeyWord &" KeyWord like '%"& P_Key &"%' And "
end if
pSql = pSql & TempKeyWord &" yn = 0 Order By Id Desc"
'Response.Write pSql
Set pRs = Server.CreateObject("Adodb.recordset")
pRs.open pSql,conn,1,3
if not(pRs.bof and pRs.eof) then
Do While Not pRs.eof
if pRs(0) <> P_ConID Then
If html=1 then
ShowMutualityArticle = ShowMutualityArticle & "<li>"&P_ICO&"<a href="""&SitePath&"List.asp?ID="&pRs(0)&""">"&pRs(1)&"</a>"
elseif html=2 then
ShowMutualityArticle = ShowMutualityArticle & "<li>"&P_ICO&"<a href="""&SitePath&"Html/?"&pRs(0)&".html"">"&pRs(1)&"</a>"
else
ShowMutualityArticle = ShowMutualityArticle & "<li>"&P_ICO&"<a href="""&SitePath&"Html/"&pRs(0)&".html"">"&pRs(1)&"</a>"
End if
If P_Time>0 then
ShowMutualityArticle = ShowMutualityArticle &" "&FormatDate(pRs(3),P_Time)&""
End if
ShowMutualityArticle = ShowMutualityArticle &"</li>" & VbCrLf
end if
pRs.movenext
Loop
else
ShowMutualityArticle = ShowMutualityArticle & "<li>没有相关文章</li>"
end if
pRs.close:set pRs = nothing
End Function
'图片文章调用
'ClassID:数值型，栏目ID
'N:数值型，要显示文章条数
'T:数值型，显示时间，０为不显示，否则为时间格式
'Z:标题字数
'msql:增强条件
'P:排序方式
Sub ShowImgArticle(ClassID,N,Z,msql,P)
set rs1=server.createobject("ADODB.Recordset")
SQL1="select Top "&N&" ID,Title,ClassID,DateAndTime,Images,Content from "&tbname&"_Article where yn = 0 and Images<>''"
If ClassID<>0 then
If Yao_MyID(ClassID)="0" then
SQL1=SQL1&" and ClassID="&ClassID&""
else
MyID = Replace(""&Yao_MyID(ClassID)&"","|",",")
SQL1=SQL1&" and ClassID in ("&MyID&")"
End if
End if
If msql<>"no" then
SQL1=SQL1&" and "&msql&""
End if
SQL1=SQL1&" Order by "&P&""
rs1.open sql1,conn,1,3
If Not rs1.Eof Then
do while not (rs1.eof or err)
Response.Write("<li>")
If Html=1 then
Response.Write("<a href="""&SitePath&"List.asp?ID="&rs1("ID")&""" target=""_blank"">")
Elseif Html=2 then
Response.Write("<a href="""&SitePath&"Html/?"&rs1("ID")&".html"" target=""_blank"">")
Else
Response.Write("<a href="""&SitePath&"Html/"&rs1("ID")&".html"" target=""_blank"">")
end if
Response.Write("<img src="""&SitePath&""&SiteUp&"/")
If IsAspJpeg=1 then
Response.Write("s90/")
End if
Response.Write(""&rs1("Images")&""" title="""&rs1("Title")&""" style=""border:1px solid #ccc;padding:2px;width:90px;height:90px;""></a>")
Response.Write("<br>")
If Html=1 then
Response.Write("<a href="""&SitePath&"List.asp?ID="&rs1("ID")&""" target=""_blank"">")
elseif html=2 then
Response.Write("<a href="""&SitePath&"Html/?"&rs1("ID")&".html"" target=""_blank"">")
Else
Response.Write("<a href="""&SitePath&"Html/"&rs1("ID")&".html"" target=""_blank"">")
end if
Response.Write(""&left(rs1("Title"),Z)&"</a>")
Response.Write("</li>") & VbCrLf
rs1.movenext
loop
'else
'Response.Write("<li>没有</li>")
end if
rs1.close
set rs1=nothing
End Sub
'文章调用
'ClassID:数值型，栏目ID
'N:数值型，要显示文章条数
'T:数值型，显示时间，０为不显示，否则为时间格式
'ICO:字符型，标题前图标，可以图片也可为字符
'Z:标题字数
'msql:增强条件
'P:排序方式
'ClassName 数值型,1为显示栏目名称,0为不显示
'target 数值型,1为在新窗口打开
Sub ShowArticle(ClassID,N,T,ICO,Z,msql,P,ClassName,target)
set rs1=server.createobject("ADODB.Recordset")
SQL1="select Top "&N&" ID,Title,ClassID,DateAndTime,TitleFontColor,IsHot from "&tbname&"_Article where yn = 0"
If ClassID<>0 then
If Yao_MyID(ClassID)="0" then
SQL1=SQL1&" and ClassID="&ClassID&""
else
MyID = Replace(""&Yao_MyID(ClassID)&"","|",",")
SQL1=SQL1&" and ClassID in ("&MyID&")"
End if
End if
If msql<>"no" then
SQL1=SQL1&" and "&msql&""
End if
SQL1=SQL1&" Order by "&P&""
rs1.open sql1,conn,1,3
If Not rs1.Eof Then
do while not (rs1.eof or err)
Response.Write("<li>")
If T<>0 then
Response.Write("<span style=""float:right;"">"&FormatDate(rs1(3),T)&"</span>")
end if
If ClassName=1 then
If Html=3 then
Response.Write("[<a href="""&SitePath&"Class_"&rs1(2)&".html"">"&Classlist(rs1(2))&"</a>]")
Else
Response.Write("[<a href="""&SitePath&"Class.asp?ID="&rs1(2)&""">"&Classlist(rs1(2))&"</a>]")
End if
End if
Response.Write(""&ICO&"<a href=""")
If Html=1 then
Response.Write(""&SitePath&"List.asp?ID="&rs1(0)&"""")
elseif Html=2 then
Response.Write(""&SitePath&"Html/?"&rs1(0)&".html""")
elseif Html=3 then
Response.Write(""&SitePath&"Html/"&rs1(0)&".html""")
end if
If target=1 then
Response.Write(" target=""_blank""")
End if
Response.Write(" >")
If rs1(4)<>"" then
Response.Write("<font style=""color:"&rs1(4)&""">"&left(rs1(1),Z)&"</font></a>")
else
Response.Write(""&left(rs1(1),Z)&"</a>")
end if
Response.Write("</li>") & VbCrLf
rs1.movenext
loop
else
Response.Write("<li>没有</li>")
end if
rs1.close
set rs1=nothing
End Sub
Function Yao_MyID(a)
Yao_MyID=""
Dim rs1,sql1
set rs1=server.createobject("ADODB.Recordset")
sql1="select ID from "&tbname&"_Class where TopID = "&a&""
rs1.open sql1,conn,1,3
If Not rs1.Eof Then
do while not (rs1.eof or err)
If Yao_MyID = "" then
Yao_MyID = rs1("ID")
else
Yao_MyID = Yao_MyID &"|"& rs1("ID")
End if
rs1.movenext
loop
else
Yao_MyID = "0"
end if
rs1.close
set rs1=nothing
End Function
Function Classlist(id)
if id = "" or isnull(id) then
Classlist = ""
else
Sqld = "Select ClassName from "&tbname&"_Class where ID = " & id
Set rsd = conn.execute(Sqld)
if not rsd.eof then
Classlist = rsd(0)
else
Classlist = ""
end if
rsd.close
end if
End Function
Function checkpost(byval back)
dim server_v1, server_v2
server_v1 = cstr(request.servervariables("http_referer"))
server_v2 = cstr(request.servervariables("server_name"))
if Mid(server_v1, 8, len(server_v2)) <> server_v2 then
if not back then
response.write lang_errorpost : response.end
else
checkpost = false
end if
else
checkpost = true
end if
end Function
Function Alert(message,gourl)
message = replace(message,"'","\'")
If gourl="-1" then
Response.Write ("<script language=javascript>alert('" & message & "');history.go(-1)</script>")
ElseIf gourl="-2" then
Response.Write ("<script language=javascript>alert('" & message & "');history.go(-2)</script>")
ElseIf gourl="Close" then
Response.Write ("<script language=javascript>alert('" & message & "');window.opener=null;window.close();</script>")
Else
Response.Write ("<script language=javascript>alert('" & message & "');location='" & gourl &"'</script>")
End If
Response.End()
End Function
Function Info(message)
Response.Redirect ""&SitePath&""&SiteAdmin&"/Info.asp?Info=" & message & ""
Response.End()
End Function
Function UserInfo(id,Num)
if id = "" or isnull(id) Then Exit Function
Sqld = "Select usergroupid,yn from "&tbname&"_User where ID = " & id
Set rsd = conn.execute(Sqld)
if not rsd.eof then
UserInfo =rsd(Num)
end if
rsd.close
set rsd=nothing
End Function
'过滤指定html标签
Function lFilterBadHTML(byval strHTML,byval strTAGs)
Dim objRegExp,strOutput
Dim arrTAG,i
arrTAG=Split(strTAGs,",")
Set objRegExp = New Regexp
strOutput=strHTML
objRegExp.IgnoreCase = True
objRegExp.Global = True
For i=0 to UBound(arrTAG)
objRegExp.Pattern = "<"&arrTAG(i)&"[\s\S]+</"&arrTAG(i)&"*>"
strOutput = objRegExp.Replace(strOutput, "")
Next
Set objRegExp = Nothing
lFilterBadHTML = strOutput
End Function
'函数名：EditUserMn
'作用：操作后，给相应用户加分
'参数：str1（被操作的用户名)
' str2(积分)
' P_MnType(操作类型，1增加，0减少)
Function EditUserMn(str1,str2,P_MnType)
dim rs,sql,rs2
dim EditorTmp,MoneyStr
sql = "Select UserName From ["&tbname&"_Article] Where ID = "&str1
Set rs2 = Conn.Execute(sql)
if not(rs2.eof And rs2.bof) then
EditorTmp = rs2(0)
sql = "Select UserMoney From ["&tbname&"_User] Where UserName = '"&EditorTmp&"'"
Set rs = Server.CreateObject("adodb.recordset")
rs.open sql,connstr,1,3
if not(rs.bof and rs.eof) then
If P_MnType = 1 then
rs(0) = LaoYRequest(rs(0)) + LaoYRequest(str2)
else
rs(0) = LaoYRequest(rs(0)) - LaoYRequest(str2)
end if
rs.update
end if
rs.close:set rs=nothing
end if
rs2.close:set rs2=nothing
End Function
'ClassID 链接分类,0为所有
'NUM 调用个数,0为不限
'logo 是否调用logo,1为logo,0为文字
'ClassName是否显示分类名，1为显示
Sub Link(ClassID,Num,logo,ClassName)
set rs1=server.createobject("ADODB.Recordset")
SQL1="select"
If Num<>0 then
SQL1=SQL1&" top "&Num&""
End if
SQL1=SQL1&" * from "&tbname&"_Link where yn <> 0 and datediff('d',Now(),AddTime) <= 0 and datediff('d',Now(),LastTime) > 0"
If ClassID<>0 then
SQL1=SQL1&" And ClassID = "&ClassID&""
End if
If logo=1 then
SQL1=SQL1&" And LogoUrl <> ''"
else
SQL1=SQL1&" And LogoUrl = ''"
End if
SQL1=SQL1&" order by num asc,id asc"
rs1.open sql1,conn,1,3
If Not rs1.Eof Then
If ClassName=1 then
Response.Write("<b>"&linkclassname(rs1("ClassID"))&"：</b>")
End if
do while not (rs1.eof or err)
Response.Write("<a href="""&rs1("LinkUrl")&""" target=""_blank"">")
If rs1("logourl")<>"" then
Response.Write("<img src="""&rs1("logourl")&""" width=""88"" height=""31"" alt="""&rs1("Title")&""">")
Else
Response.Write(""&rs1("Title")&"")
End if
Response.Write("</a>") & VbCrLf
rs1.movenext
loop
end if
rs1.close
set rs1=nothing
End Sub
Function linkclassname(id)
if id = "" or isnull(id) then
linkclassname = ""
else
Sqld = "Select LinkName from "&tbname&"_LinkClass where ID = " & id
Set rsd = conn.execute(Sqld)
if not rsd.eof then
linkclassname = rsd(0)
else
linkclassname = ""
end if
rsd.close
set rsd=nothing
end if
End Function
Function showFace(Str)
for i = 1 to PingNum
Str=replace(Str,"[laoy:"&i&"]","<img src="""&SitePath&"images/faces/"&i&".gif""></img>")
Next
showFace=Str
End Function
Function ReplaceshowFace(Str)
for i = 1 to PingNum
Str=replace(Str,"[laoy:"&i&"]","")
Next
ReplaceshowFace=Str
End Function
Function RndNumber(Min,Max)
Randomize
RndNumber=Int((Max - Min + 1) * Rnd() + Min)
End Function
Sub ShowVote(t0)
sqlVote="select top 1 id,title,vote,result,stype from "&tbname&"_vote Where yn = 1"
if clng(t0)<>0 then sqlVote=sqlVote&" And id="&clng(t0)&""
sqlVote=sqlVote&" order by id desc"
set rsVote=conn.execute(sqlVote)
if rsVote.eof then
Response.Write ""
else
if rsVote(4)=1 then
v_type="radio"
else
v_type="checkbox"
end if
Response.Write "<form action="""&SitePath&"Vote.asp?action=add&id="&rsVote(0)&""" method=""post"" target=""vote"">"
Response.Write "<h5>"&rsVote(1)&"</h5>"
result=split(rsVote(3),"|")
for i=0 to ubound(result)
next
vote=split(rsVote(2),"|")
for i=0 to ubound(vote)-1
Response.Write "<li><input type="""&v_type&""" name=""vote"" value="""&i&""">"&vote(i)&"</li>"
next
Response.Write "<li><input type=""submit"" value=""投票"" class=""artsubmit""> <input type=""button"" onclick=""window.open('"&SitePath&"Vote.asp?action=see&id="&rsVote(0)&"')"" value=""查看"" class=""artsubmit""></li>"
Response.Write "</form>"
end if
RsVote.Close:Set RsVote = Nothing
End Sub
Function ShowVoteList(P_VoteID)
dim oRs
Set oRs = Conn.Execute("Select ID,Title from "&tbname&"_Vote Order by Px asc,ID desc")
If Not(oRs.eof And oRs.bof) Then
Do While Not oRs.eof
ShowVoteList = ShowVoteList &"<option value='"&oRs("ID")&"'"
if Instr(","& P_VoteID &",",","& oRs("ID") &",") > 0 Then ShowVoteList = ShowVoteList &" selected"
ShowVoteList = ShowVoteList &">" & oRs("Title")&"</option>" & vbNewLine
oRs.movenext
Loop
Else
ShowVoteList = "没有!"
End If
oRs.Close:Set oRs = Nothing
End Function
Function ShowVoteList2(P_VoteID)
dim oRs,b
Set oRs = Conn.Execute("Select ID,Title from "&tbname&"_Vote Where ID in("&P_VoteID&")")
b=split(P_VoteID,",")
For i = 0 to Ubound(b)
Response.Write("<div class=""artvote"">") & VbCrLf
Response.Write(" <ul>") & VbCrLf
Call ShowVote(b(i))
Response.Write(" </ul>") & VbCrLf
Response.Write("</div>") & VbCrLf
Next
oRs.Close:Set oRs = Nothing
End Function
Function ChkSB(str)
ChkSB = True
For i=0 To Ubound(Split(KillWord,","))
If Instr(Str,Split(KillWord,",")(i)) > 0 Then
ChkSB = False
Exit Function
End If
Next
End Function
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If Err = 0 Then IsObjInstalled = True
If Err = -2147352567 Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
Sub Web_Style()
Dim Sqlp,Rsp,TempStr
Sqlp ="Select ID,Title from "&tbname&"_Css"
Set Rsp=server.CreateObject("adodb.recordset")
rsp.open sqlp,conn,1,1
If Rsp.Eof and Rsp.Bof Then
Response.Write("<option value="""">请先添加风格</option>")
Else
Do while not Rsp.Eof
Response.Write("<option value=""" & Rsp("ID") & """")
If int(css)=Rsp("ID") then
Response.Write(" selected" )
End if
Response.Write(">" & Rsp("Title") & "</option>") & VbCrLf
Rsp.Movenext
Loop
End if
Rsp.Close:Set Rsp=nothing
End Sub
Function ReplaceKey(ByVal Str)
If IsNull(Str) Then Exit Function
Dim RsKeyword
sql="Select * From ["&tbname&"_Key] Order By [Num] Desc"
Set RsKeyword=Conn.Execute(sql)
do while not (RsKeyword.eof or err)
If InStr(Str,RsKeyword("Title")) > 0 Then
oReplace = RsKeyword("Replace")
If oReplace=0 then oReplace=-1
Str = p_replace(Str,RsKeyword("Title"),"<a href="""&RsKeyword("Url")&""" target=""_blank""><font color=blue>"&RsKeyword("Title")&"</font></a>",1,oReplace,1)
End if
RsKeyword.movenext
loop
ReplaceKey = Str
RsKeyword.Close:Set RsKeyword=nothing
End Function
Function p_replace(byval content,byval asp,byval htm,byval aa,byval Rnum,byval bb)
dim Matches,objRegExp,strs,i
strs=content
Set objRegExp = New Regexp
objRegExp.Global = True
objRegExp.IgnoreCase = True
objRegExp.Pattern = "(\<a[^<>]+\>.+?\<\/a\>)|(\<img[^<>]+\>)"'
Set Matches =objRegExp.Execute(strs)
i=0
Dim MyArray()
For Each Match in Matches
ReDim Preserve MyArray(i)
MyArray(i)=Mid(Match.Value,1,len(Match.Value))
strs=replace(strs,Match.Value,"<"&i&">",1,Rnum,1)
i=i+1
Next
if i=0 then
content=replace(content,asp,htm,1,Rnum,1)
p_replace=content
exit Function
end if
strs=replace(strs,asp,htm,1,Rnum,1)
for i=0 to ubound(MyArray)
strs=replace(strs,"<"&i&">",MyArray(i),1,Rnum,1)
next
p_replace=strs
end Function
Function ShowLabel(id)
if id = "" or isnull(id) then
ShowLabel = 0
else
Sqld = "Select Content from "&tbname&"_Label where ID = " & id
Set rsd = conn.execute(Sqld)
if not rsd.eof then
ShowLabel = rsd(0)
else
ShowLabel = ""
end if
rsd.close
end if
End function
Function RandReg(str)
if str = "" then
RandReg = ""
else
RReg=split(str,CHR(10))
for i=0 to ubound(RReg)
RReg1 = RReg(i)
next
RandReg = RReg1
end if
End function
%>