<%
'Option Explicit
on error resume next
'------------------------------------------------------
Dim shop,my_domains,my_url,my_name,toptitle,Websitekeyword,descriptions,my_zhuce,WebsitePageUrl
Dim ChoiceMaxDay,PublicChoiceMaxDay,PublicShowMaxDay
Dim IsSqlDataBase
Dim SqlNow,Conn,online_sj,SQLDATE,ConnStr,SERVER_url
'****营销联盟****
dim From_ID
From_ID=IsNumeric_("welcome")
From_ID_=Trim(Request.Cookies("TallZhi_Spread")("From_ID"))
If From_ID_="" and From_ID<>"" Then
Response.Cookies("TallZhi_Spread")("From_ID")=From_ID
Response.Cookies("TallZhi_Spread").Expires=DateAdd("d",1,now())'保存一周
Else
From_ID=From_ID_
End If
function IsNumeric_(str)
dim values
values=Trim(request(str))
if not IsNumeric(values) and values<>"" then
Jstop("非法操作")
Else
IsNumeric_=values
End if
end function
'****结束****
SqlNow = now()
IsSqlDataBase=1
if IsSqlDataBase = 1 then
SQLDATE = "getdate()"
else
SQLDATE = "now()"
end if
ConnStr = "Provider = Sqloledb; User ID =tallzhicom ; Password =caiZhi#@!125; Initial Catalog =tallzhiba ; Data Source =(local) ;"
Sub Open_Conn(Conn,Connstr)
'On Error Resume Next
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnStr
'response.write Err.number
If Err.number>0 Then
err.Clear
Set Conn = Nothing
Response.Write "数据库连接出错，请检查连接字串。"
Response.End
End If
End Sub
Sub End_Conn(Conn)
Conn.Close
Set Conn = Nothing
End Sub
SERVER_url=Request.ServerVariables("SERVER_NAME")
Function saferequest(value)
Dim ParaValue
ParaValue = Trim(Request(value))
If IsNumeric(ParaValue) = True Then
saferequest = ParaValue
Exit Function
ElseIf InStr(LCase(ParaValue), "select ") > 0 Or InStr(LCase(ParaValue), "insert ") > 0 Or InStr(LCase(ParaValue), "delete from") > 0 Or InStr(LCase(ParaValue), "count(") > 0 Or InStr(LCase(ParaValue), "drop table") > 0 Or InStr(LCase(ParaValue), "update ") > 0 Or InStr(LCase(ParaValue), "truncate ") > 0 Or InStr(LCase(ParaValue), "asc(") > 0 Or InStr(LCase(ParaValue), "mid(") > 0 Or InStr(LCase(ParaValue), "char(") > 0 Or InStr(LCase(ParaValue), "xp_cmdshell") > 0 Or InStr(LCase(ParaValue), "exec master") > 0 Or InStr(LCase(ParaValue), "net localgroup administrators") > 0 Or InStr(LCase(ParaValue), " and ") > 0 Or InStr(LCase(ParaValue), "net user") > 0 Or InStr(LCase(ParaValue), " or ") > 0 Or InStr(LCase(ParaValue), "'") > 0 Or InStr(LCase(ParaValue), "''") > 0 Then
response.Write("")
response.End()
Else
saferequest = ParaValue
End If
End Function
Function renzheng()
Select case rz
case 3
Response.Write " "
case 2
Response.Write " "
case 1
Response.Write " "
case 0
Response.Write " "
End Select
End Function
Dim xing1,xing2,xing3,xing4,xing5,xing6,xing7,xing8,xing11,xing21,xing31,xing41,xing51,xing71
'星级设置
xing1="9"
xing2="50"
xing3="100"
xing4="200"
xing5="500"
xing6="900"
xing7="1800"
xing8="3000"
xing11="49"
xing21="99"
xing31="199"
xing41="499"
xing51="899"
xing6="900"
xing71="1799"
Function getlen(Str)
'取字符串长度，中文为两个字节
Dim P_Len, XX
P_Len = 0
getlen = 0
If Not IsNull(Str) And Str <> "" Then
P_Len = Len(Str)
For XX = 1 To P_Len
If Asc(Mid(Str, XX, 1)) < 0 Then
getlen = CLng(getlen) + 2
Else
getlen = CLng(getlen) + 1
End If
Next
End If
End Function
'================================================
'函数名：strLength
'作 用：计字符串长度
'参 数：str ----字符串
'================================================
Public Function strLength(ByVal str)
On Error Resume Next
If IsNull(str) Or str = "" Then
strLength = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE = (Len("例子") = 2)
If WINNT_CHINESE Then
Dim l, t
Dim i, c
l = Len(str)
t = l
For i = 1 To l
c = Asc(Mid(str, i, 1))
If c < 0 Then c = c + 65536
If c > 255 Then t = t + 1
Next
strLength = t
Else
strLength = Len(str)
End If
End Function
Function FilterString(ByVal strWord, ByVal intByteLength)
If strWord <> "" Then
dim HtmlStr
HtmlStr = strWord
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, """", Chr(34))
HtmlStr = Replace(HtmlStr, "'", Chr(39))
HtmlStr = Replace(HtmlStr, "{", Chr(123))
HtmlStr = Replace(HtmlStr, "}", Chr(125))
HtmlStr = Replace(HtmlStr, "$", Chr(36))
HtmlStr = Replace(HtmlStr, vbCrLf, "")
HtmlStr = Replace(HtmlStr, "====", "")
HtmlStr = Replace(HtmlStr, "----", "")
HtmlStr = Replace(HtmlStr, "////", "")
HtmlStr = Replace(HtmlStr, "\\\\", "")
HtmlStr = Replace(HtmlStr, "####", "")
HtmlStr = Replace(HtmlStr, "@@@@", "")
HtmlStr = Replace(HtmlStr, "****", "")
HtmlStr = Replace(HtmlStr, "~~~~", "")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[br\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "\[align=right\](.*)\[\/align\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "<(.[^>]*)>"
HtmlStr = re.Replace(HtmlStr, "")
Set re = Nothing
HtmlStr = Replace(HtmlStr, ">", ">")
HtmlStr = Replace(HtmlStr, "<", "<")
If strLength(HtmlStr) <= intByteLength Then
FilterString = HtmlStr
Else
Dim i
Dim intLength
Dim strChar
Dim bytChar
intLength = 0
For i = 1 to Len(HtmlStr)
strChar = Mid(HtmlStr, i, 1)
bytChar = Asc(Mid(HtmlStr, i, 1))
If bytChar < 0 or bytChar > 255 Then
intLength = intLength + 2
Else
intLength = intLength + 1
End If
If intLength > intByteLength Then Exit For
FilterString = FilterString & strChar
Next
'FilterString = FilterString & String(intPadDotAmount, ".")
FilterString = FilterString & "..."
End If
Else
FilterString = ""
End If
End Function
Function CutString(ByVal strWord, ByVal intByteLength)
If strWord <> "" Then
dim HtmlStr
HtmlStr = strWord
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, """", Chr(34))
HtmlStr = Replace(HtmlStr, "'", Chr(39))
HtmlStr = Replace(HtmlStr, "{", Chr(123))
HtmlStr = Replace(HtmlStr, "}", Chr(125))
HtmlStr = Replace(HtmlStr, "$", Chr(36))
HtmlStr = Replace(HtmlStr, vbCrLf, "")
HtmlStr = Replace(HtmlStr, "====", "")
HtmlStr = Replace(HtmlStr, "----", "")
HtmlStr = Replace(HtmlStr, "////", "")
HtmlStr = Replace(HtmlStr, "\\\\", "")
HtmlStr = Replace(HtmlStr, "####", "")
HtmlStr = Replace(HtmlStr, "@@@@", "")
HtmlStr = Replace(HtmlStr, "****", "")
HtmlStr = Replace(HtmlStr, "~~~~", "")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[br\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "\[align=right\](.*)\[\/align\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "<(.[^>]*)>"
HtmlStr = re.Replace(HtmlStr, "")
Set re = Nothing
HtmlStr = Replace(HtmlStr, ">", ">")
HtmlStr = Replace(HtmlStr, "<", "<")
If strLength(HtmlStr) <= intByteLength Then
CutString = HtmlStr
Else
Dim i
Dim intLength
Dim strChar
Dim bytChar
intLength = 0
For i = 1 to Len(HtmlStr)
strChar = Mid(HtmlStr, i, 1)
bytChar = Asc(Mid(HtmlStr, i, 1))
If bytChar < 0 or bytChar > 255 Then
intLength = intLength + 2
Else
intLength = intLength + 1
End If
If intLength > intByteLength Then Exit For
CutString = CutString & strChar
Next
'CutString = CutString & String(intPadDotAmount, ".")
'CutString = CutString & "..."
End If
Else
CutString = ""
End If
End Function
function forprice(snum)
if not isnumeric(snum) then forprice=0
if snum<1 then
forprice=cstr(0&snum)
forprice=replace(forprice,"00","0")
forprice=replace(forprice,"0.00","0")
forprice=replace(forprice,"0.0","0")
else
forprice=snum
end if
end function
function checkStr(str)
str = replace(str," ","")
str = replace(str,",","，")
str = replace(str,"'","”")
str = replace(str,"<","<")
str = replace(str,">",">")
str = replace(str,";","；")
checkStr = str
end function
TaskSiteUrl="http://www.taskba.cn"
KillWordString=""
Call Open_Conn(Conn,Connstr)
Set Rs = Server.CreateObject("ADODB.Recordset")
strSQL = "SELECT S_KillWords FROM B_System"
rs.Open strSQL,conn,1,1
If not Rs.Eof Then
KillWordString=Rs(0)
End If
Rs.Close
Set Rs=Nothing
Call End_Conn(Conn)
Function KillWord(strContent)
KillWordArray=Split(KillWordString, "|")
For i=0 To Ubound(KillWordArray)
strContent = Replace(strContent,KillWordArray(i),"***")
Next
KillWord=strContent
End Function
Dim BannedText,BannedHtmlEvent,BannedHtmlLabel
BannedText= "你妈的|吃屎|做爱"
BannedHtmlEvent="javascript:|onerror|onload|onmouseover"
BannedHtmlLabel="javascript:|onerror|onload|onmouseover"
''''''''''''''''''''''''''''''''''''
function HTMLEncode(fString)
fString=Server.HtmlEncode(fString)
fString=Replace(fString,"&","&")'
fString=Replace(fString,"\","\")
fString=Replace(fString,"--","--")
fString=Replace(fString,CHR(9)," ")
fString=Replace(fString,CHR(10)," ")
fString=Replace(fString,CHR(13),"")
fString=Replace(fString,CHR(22),"")
fString=Replace(fString,CHR(32)," ")
fString=Replace(fString,CHR(39),"'")'单引号
fString=Replace(fString,";",";")
fString=ReplaceText(fString,"([&#])([a-z0-9]*);","$1$2;")
if IsSqlDataBase=0 then '过滤片假名(日文字符)[\u30A0-\u30FF] by yuzi首创
fString=escape(fString)
fString=ReplaceText(fString,"%u30([A-F][0-F])","0$1;")
fString=unescape(fString)
end if
HTMLEncode=fString
end function
''''''''''''''''''''''''''''''''''''
''''''''''替换模块START''''''''''''
Function ReplaceText(fString,patrn,replStr)
Set regEx = New RegExp ' 建立正则表达式。
regEx.Pattern = patrn ' 设置模式。
regEx.IgnoreCase = True ' 设置是否区分大小写。
regEx.Global = True ' 设置全局可用性。
ReplaceText = regEx.Replace(""&fString&"",""&replStr&"") ' 作替换。
Set reg=nothing
End Function
''''''''''替换模块END''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function ContentEncode(fString)
fString=Replace(fString,"","")
fString=Replace(fString,"\","\")
fString=Replace(fString,vbCrlf, "")
fString=Replace(fString,"\","\")
fString=Replace(fString,"'","'")
fString=Replace(fString,""" then fString=ReplaceText(fString,"<(.[^>]*)("&BannedHtmlEvent&")", "<$1$2")
if BannedText<>"" then
filtrate=split(BannedText,"|")
for i = 0 to ubound(filtrate)
fString=ReplaceText(fString,""&filtrate(i)&"",string(len(filtrate(i)),"*"))
next
end if
contentEncode=fString
end function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function YbbEncode(str)
str=ReplaceText(str,"\[(\/|)(b|i|u|strike|center|blockquote|marquee)\]","<$1$2>")
str=ReplaceText(str,"\[COLOR=([^[]*)\]","")
str=ReplaceText(str,"\[FONT=([^[]*)\]","")
str=ReplaceText(str,"\[SIZE=([0-9]*)\]","")
str=ReplaceText(str,"\[\/(SIZE|FONT|COLOR)\]","")
str=ReplaceText(str,"\[URL\]([^[]*)","$1")
str=ReplaceText(str,"\[URL=([^[]*)\]","")
str=ReplaceText(str,"\[\/URL\]","")
str=ReplaceText(str,"\[EMAIL\](\S+\@[^[]*)(\[\/EMAIL\])","$1")
str=ReplaceText(str,"\[IMG\]([^"&CHR(34)&"[]*)(\[\/IMG\])","")
str=ReplaceText(str,"\[quote user="&CHR(34)&"([^[]*)"&CHR(34)&"\]","
$1: ")
str=ReplaceText(str,"\[\/quote\]","
")
YbbEncode=str
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
function killstr(str)
dim tempstr
if str="" then exit function
tempstr=replace(str,chr(34),"") ' "
tempstr=replace(tempstr,chr(39),"") ' '
tempstr=replace(tempstr,chr(60),"") ' <
tempstr=replace(tempstr,chr(62),"") ' >
tempstr=replace(tempstr,chr(37),"") ' %
tempstr=replace(tempstr,chr(38),"") ' &
tempstr=replace(tempstr,chr(40),"") ' (
tempstr=replace(tempstr,chr(41),"") ' )
tempstr=replace(tempstr,chr(59),"") ' ;
tempstr=replace(tempstr,chr(43),"") ' +
tempstr=replace(tempstr,chr(45),"") ' -
tempstr=replace(tempstr,chr(91),"") ' [
tempstr=replace(tempstr,chr(93),"") ' ]
tempstr=replace(tempstr,chr(123),"") ' {
tempstr=replace(tempstr,chr(125),"") ' }
killstr=tempstr
end function
Function HTMLEncode_(ByVal reString)
Dim Str:Str=reString
If Not IsNull(Str) Then
Str = Replace(Str, ">", ">")
Str = Replace(Str, "<", "<")
Str = Replace(Str, " ", CHR(9))
Str = Replace(Str, "'", CHR(39))
Str = Replace(Str, """", CHR(34))
Str = Replace(Str, "", CHR(13))
Str = Replace(Str, " ", CHR(10))
HTMLEncode_ = Str
End If
End Function
%>
<%
shop="tallzhi"
my_domains="tallzhi.com"
Response.Cookies(shop).path="/"
my_url="www.tallzhi.com"
my_name="淘智网"
toptitle="致力打造中国最好的C2C威客智慧交易平台！"
Websitekeyword="买卖智慧,智慧交易,兼职,上班兼职,网上兼职,网络兼职,赚外快,卖点子,卖智慧,智慧交易,买卖智慧,网赚,网络赚钱,网上赚钱,博客赚钱,外包,威客,智客,慧客,自由职业"
descriptions="在淘智网上，您可以把智慧、经验、知识、技能作为商品进行交易。您既可以出售您本身拥有的智慧产品和服务而获得收益，也可以求购您需要的智慧产品和服务，从而解决您工作的难题。在交易过程中，淘智网将通过实名认证、第三方支付、信用担保等方式，提供安全可靠的服务保障。交易成功后，成交金额的80%付给卖家，剩余20%留在淘智网，作为共同发展基金，由淘智网负责支配，用于网站建设、宣传推广、日常运营等各方面，从而更好的向用户提供优质的服务。"
my_zhuce=htmlencode("
")
'“任务”部分参数
ChoiceMaxDay=10'选稿期持续天数
PublicChoiceMaxDay=1'公众投票选稿天数
PublicShowMaxDay=0'公示期天数
%>
<%
Sub shengchengid(shopid)
'生成店铺文件夹
Dim Folder,FolderPath
Folder=shopid
FolderPath="/Shop/"&Folder&"/"
CreateFolder(FolderPath)
'复制模版文件到店铺文件夹
Call copyfile("/Shop/shopcopy/index.shtml",FolderPath&"index.shtml")
Call copyfile("/Shop/shopcopy/blog.shtml",FolderPath&"blog.shtml")
Call copyfile("/Shop/shopcopy/CreateShopList.shtml",FolderPath&"CreateShopList.shtml")
Call copyfile("/Shop/shopcopy/creditList.shtml",FolderPath&"creditList.shtml")
Call copyfile("/Shop/shopcopy/Not_creditList.shtml",FolderPath&"Not_creditList.shtml")
Call copyfile("/Shop/shopcopy/Not_shopcreditList.shtml",FolderPath&"Not_shopcreditList.shtml")
Call copyfile("/Shop/shopcopy/ProductSellList.shtml",FolderPath&"ProductSellList.shtml")
Call copyfile("/Shop/shopcopy/Require.shtml",FolderPath&"Require.shtml")
Call copyfile("/Shop/shopcopy/ShopClass.shtml",FolderPath&"ShopClass.shtml")
Call copyfile("/Shop/shopcopy/Task_myjoin.shtml",FolderPath&"Task_myjoin.shtml")
Call copyfile("/Shop/shopcopy/task_product.shtml",FolderPath&"task_product.shtml")
Call copyfile("/Shop/shopcopy/TaskList.shtml",FolderPath&"TaskList.shtml")
Call copyfile("/Shop/shopcopy/Wit.shtml",FolderPath&"Wit.shtml")
Call copyfile("/Shop/shopcopy/Credit_Info.shtml",FolderPath&"Credit_Info.shtml")
Call copyfile("/Shop/shopcopy/shopcreditList.shtml",FolderPath&"shopcreditList.shtml")
Call copyfile("/Shop/shopcopy/task.shtml",FolderPath&"task.shtml")
End sub
'a为要去字符的内容,b为开始字符,c为结束字符 去除从某段字符到另一字符之间的字符串
Function StrChar(a,b,c)
Dim ConStrTemp,StartStr,OverStr,Start,Over,GetBody,d
do while instr(a,b)>0 and instr(a,c)>0
ConStrTemp=Lcase(a)
StartStr=Lcase(b)
OverStr=Lcase(c)
Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
Start = Start+LenB(StartStr)
Over = InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)
Over = Over+LenB(OverStr)
GetBody = MidB(a,Start,Over-Start)
d=b&GetBody
a=replace(a,d,"")
loop
StrChar=a
end function
function checkint(str,def)
'检测输入的是否是整数
'str 输入的字符串，def如果str非法则返回的整数
if len(str)= 0 or isnull(str) then
checkint = def
exit function
end if
if isnumeric(str) then
checkint=clng(str)
else
checkint=def
end if
end function
'================================================
'函数名：GetStrLen
'作 用：'取字符串长度，中文为两个字节
'参 数：str ----原字符串
'================================================
Function GetStrLen(Str)
Dim P_Len, XX
P_Len = 0
GetStrLen = 0
If Not IsNull(Str) And Str <> "" Then
P_Len = Len(Str)
For XX = 1 To P_Len
If Asc(Mid(Str, XX, 1)) < 0 Then
GetStrLen = CLng(GetStrLen) + 2
Else
GetStrLen = CLng(GetStrLen) + 1
End If
Next
End If
End Function
'=============================================================
'函数作用：检测身份证号码是否正确
'=============================================================
Function CheckCardId(e)
arrVerifyCode = Split("1,0,x,9,8,7,6,5,4,3,2", ",")
Wi = Split("7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2", ",")
Checker = Split("1,9,8,7,6,5,4,3,2,1,1", ",")
If Len(e) < 15 Or Len(e) = 16 Or Len(e) = 17 Or Len(e) > 18 Then
CheckCardId= "身份证号共有 15 码或18位"
Exit Function
End If
Dim Ai
If Len(e) = 18 Then
Ai = Mid(e, 1, 17)
ElseIf Len(e) = 15 Then
Ai = e
Ai = Left(Ai, 6) & "19" & Mid(Ai, 7, 9)
End If
If Not IsNumeric(Ai) Then
CheckCardId= "身份证除最后一位外，必须为数字！"
Exit Function
End If
Dim strYear, strMonth, strDay
strYear = CInt(Mid(Ai, 7, 4))
strMonth = CInt(Mid(Ai, 11, 2))
strDay = CInt(Mid(Ai, 13, 2))
BirthDay = Trim(strYear) + "-" + Trim(strMonth) + "-" + Trim(strDay)
If IsDate(BirthDay) Then
If DateDiff("yyyy",Now,BirthDay)<-140 or cdate(BirthDay)>date() Then
CheckCardId= "身份证输入错误！"
Exit Function
End If
If strMonth > 12 Or strDay > 31 Then
CheckCardId= "身份证输入错误！"
Exit Function
End If
Else
CheckCardId= "身份证输入错误！"
Exit Function
End If
Dim i, TotalmulAiWi
For i = 0 To 16
TotalmulAiWi = TotalmulAiWi + CInt(Mid(Ai, i + 1, 1)) * Wi(i)
Next
Dim modValue
modValue = TotalmulAiWi Mod 11
Dim strVerifyCode
strVerifyCode = arrVerifyCode(modValue)
Ai = Ai & strVerifyCode
CheckCardId = Ai
If Len(e) = 18 And e <> Ai Then
CheckCardId= "身份证输入错误！"
Exit Function
End If
CheckCardId ="True"
End Function
'=============================================================
'函数作用：匹配正则表达式
'=============================================================
Function CheckExp(patrn, strng)
Dim regEx,Match'建立变量。
Set regEx = New RegExp'建立正则表达式。
regEx.Pattern = patrn'设置模式。
regEx.IgnoreCase = true'设置是否区分字符大小写。
regEx.Global = True'设置全局可用性。
Matches = regEx.test(strng)'执行搜索。
CheckExp = matches
End Function
'-------------------------------------------------------------
' Function Name : IsValidString
' Function Desc : 判断输入是否是一个由 0-9 / A-Z / a-z / . / _ 组成的字符串
'-------------------------------------------------------------
Function IsValidString(sInput)
Dim oRegExp
'建立正则表达式
Set oRegExp = New RegExp
'设置模式
oRegExp.Pattern = "^[a-zA-Z0-9\s.\-_]+$"
'设置是否区分字符大小写
oRegExp.IgnoreCase = True
'设置全局可用性
oRegExp.Global = True
'执行搜索
IsValidString = oRegExp.Test(sInput)
Set oRegExp = Nothing
End Function
function checknumber(str,def)
if len(str)= 0 or isnull(str) then
checknumber = def
exit function
end if
if isnumeric(str) then
checknumber=str
else
checknumber=def
end if
end function
'安全除法
Function SafeDiv(A,B)
SafeDiv = checknumber(A,0) / checknumber(B,1)
End Function
function checksqlstr(getstr)
'检测输入的参数是否含有sql敏感字符，如果有返回空字符串
dim strfilter,strtmp,i,regEx
if len(getstr) = 0 or isnull(getstr) then
checksqlstr = ""
exit function
end if
Set regEx = New RegExp
strfilter = "select|delete|update|drop|create|exec"
regEx.Pattern = strfilter
regEx.IgnoreCase = True
regEx.Global = True
getstr = trim(regex.Replace(getstr,""))
strfilter="'"
regEx.Pattern= strfilter
getstr = trim(regex.Replace(getstr,"''"))
strfilter="0x"
regEx.Pattern= strfilter
getstr = trim(regex.Replace(getstr,""))
regex.Pattern="法[\s ]*轮[\s ]*功"
getstr=regex.Replace(getstr,"*轮*")
set regex=nothing
checksqlstr = getstr
end function
function checkuserstr(str)
'检测用户注册名
if len(str) = 0 or isnull(str) then
checkuserstr = ""
exit function
end if
dim i
dim lb_user,strfilter,regEx,str1
str1 = "[A-Za-z0-9|\u4e00-\u9fa5]*" '输入的数据必须是中文
strfilter="\$|\(|\)|\*|\+|\-|\.|\[|]|\?|\\|\^|\{|\||}|~|`|!|@|#|%|&|_|=|<|>|/|,|'| | |\:|cubcn|admin|administrator|administrators|luo|老罗|system"
Set regEx = New RegExp
regEx.Pattern = strfilter
regEx.IgnoreCase = True
lb_user = regex.Test(str)
if not lb_user then
regex.Pattern="法[ ]*轮[ ]*功"
checkuserstr = regex.Replace(str,"")
else
checkuserstr = ""
end if
'regEx.Pattern = str1
'regEx.IgnoreCase = True
'lb_user = regex.Test(str)
'if not lb_user then
' checkuserstr = ""
'end if
'dim regEx2,strfilter1
'strfilter1 = "^[A-Za-z0-9\u4e00-\u9fa5]+$" '输入的数据必须是中文
'Set regEx2 = New RegExp
'regEx2.Pattern = strfilter1
'regEx2.IgnoreCase = True
'if not regex2.Test(str) then
' checkuserstr = ""
'end if
'set regex2 = nothing
set regex=nothing
end function
'组合文件路径
function JoinPath(Fstr,Estr)
Dim T_Fstr,T_Estr,TmpStr
T_Fstr = Fstr
T_Estr = Estr
TmpStr=Right(Fstr,1)
if TmpStr="/" or TmpStr ="\" then
T_Fstr = Left(Fstr,len(Fstr)-1)
end if
TmpStr=Left(Estr,1)
if TmpStr="/" or TmpStr ="\" then
T_Estr = Right(Estr,len(Estr)-1)
end if
JoinPath = T_Fstr & "/" & T_Estr
end function
'把虚拟路径,转志当前物理路径
Function PathToCurrent(FpathStr)
PathToCurrent = Server.MapPath(FpathStr)
End Function
'返回文件名的后缀 参数是文件名
Function ReturnFileExt(SouStr)
Dim Ind
Ind = InStr(SouStr,".")
ReturnFileExt = Mid(SouStr,Ind)
End Function
Function Cutstr(str,num)
If GetStrLen(str)>num Then
str = Left(str,num/2)
End If
Cutstr = str
End Function
Function CutstrPoint(str,num)
If GetStrLen(str)>num Then
str = Left(str,num/2) & "..."
End If
CutstrPoint = str
End Function
Sub jstop(strmsg)
'显示信息并回退一步
dim html
html = ""
response.Write html
'response.redirect "../index.asp"
response.End
End sub
Sub JsAlertMsg(strmsg)
Dim html
html = ""
response.Write html
End Sub
Sub JsAlertAndGoto(strmsg,Url)
Dim html
html = ""
response.Write html
Response.end
End Sub
Sub JsAlertAndGoto_(strmsg,Url)
Dim html
html = ""
response.Write html
Response.end
End Sub
Sub JsAlertAndGoto_1(strmsg,Url01,Url02)
Dim html
html = ""
response.Write html
Response.end
End Sub
//FSO函数，方法开始
Rem 得到内容
Function GetTxt(Path)
On Error resume next
Dim Ph,fso,ts
Set fso = CreateObject("Scripting.FileSystemObject")
ph=server.mappath(Path)
Set ts = fso.OpenTextFile(ph, 1)
GetTxt = ts.ReadAll
ts.Close
End Function
Rem 检测目录是否存在,不存在则建立目录
Function CreateFolder(Folder)
DIM FSO
Set fso = Server.CreateObject("Scripting.FileSystemObject")
if Not fso.FolderExists(Server.MapPath(Folder)) Then
fso.CreateFolder(Server.MapPath(Folder))
End if
Set Fso = Nothing
If Err.number<>0 Then
err.Clear
Response.Write "权限错误!!请检查您的IIS默认的匿名用户是否对本系统所在的目录有读,写,修改权限!!2"
Response.End
End If
End Function
Rem 删除文件
Function DelFile(Path)
DIM fso
Set fso=Server.CreateObject("Scripting.FileSystemObject")
IF fso.FileExists(Server.MapPath(Path)) then
fso.DeleteFile(Server.MapPath(Path))
End IF
Set fso=Nothing
End Function
Rem 删除目录
Function DelFolder(Path)
DIM fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
IF fso.FolderExists(Server.MapPath(Path)) then
fso.DeleteFolder(Server.MapPath(Path))
End IF
Set fso=Nothing
End Function
Rem 拷贝文件
Sub copyfile(movefiles, copyfiles)
movefiles = Server.MapPath(movefiles)
copyfiles = Server.MapPath(copyfiles)
Dim Fso
Set fso = Server.CreateObject("Scripting.FileSystemObject")
fso.CopyFile movefiles, copyfiles
Set fso = Nothing
End Sub
Rem 检测用户上传目录是否已满
Function IsFolder(UserID,Zise)
IsFolder=0
Dim IsFolderf,IsFolderfso
Set IsFolderfso = CreateObject("Scripting.FileSystemObject")
Set IsFolderf = IsFolderfso.GetFolder(Server.MapPath(GetUpLoadDir(UserID)))
IsFolder=IsFolderf.Size
Set IsFolderf=Nothing:Set IsFolderfso=Nothing
IF IsFolder>=(Zise*1024*1024) Then
IsFolder=False
Else
IsFolder=True
End IF
End Function
REM 写入文件
Sub WriteStream(FileName,BodyText)
On Error resume next
DIM WriteAdo
Set WriteAdo = Server.CreateObject("ADODB.Stream")
With WriteAdo
.Open
.Charset = "gb2312"
.WriteText BodyText
.SaveToFile Server.MapPath(FileName),2
.Close
End With
Set WriteAdo = Nothing
End Sub
//日期函数
Function makefilename(fname)
'fname = now()
fname = replace(fname,"-","")
fname = replace(fname," ","")
fname = replace(fname,":","")
fname = replace(fname,"PM","")
fname = replace(fname,"AM","")
fname = replace(fname,"上午","")
fname = replace(fname,"下午","")
makefilename=fname
end Function
'===================================================================
' 时间转换函数2
'===================================================================
function chan_data(shijian)
Dim s_year,s_month,s_day,s_hour
s_year=year(shijian)
if len(s_year)=2 then s_year="20"&s_year
s_month=month(shijian)
if s_month<10 then s_month="0"&s_month
s_day=day(shijian)
if s_day<10 then s_day="0"&s_day
s_hour=hour(shijian)
chan_data =s_year & s_month
end function
'===================================================================
' 时间转换函数3
'===================================================================
function chan_day(shijian)
Dim s_day
s_day=day(shijian)
chan_day=s_day
end function
'===================================================================
'函数功能：替换文章内容模版内容
'参数说明：(略)
'===================================================================
Function Replace_ModeContent(TempletContent,SiteTitle,SiteUrl,position,title,keywords,Addtime,Sources,author,Writer,content,id,classid,ClassName,Join_Record)
TempletContent=replace(TempletContent,"$SiteTitle$",SiteTitle)
TempletContent=replace(TempletContent,"$SiteUrl$",SiteUrl)
TempletContent=replace(TempletContent,"$Position$",position)
TempletContent=replace(TempletContent,"$Title$",title)
TempletContent=replace(TempletContent,"$keywords$",keywords)
TempletContent=replace(TempletContent,"$Addtime$",Addtime)
TempletContent=replace(TempletContent,"$Source$",Sources)
TempletContent=replace(TempletContent,"$Author$",author)
TempletContent=replace(TempletContent,"$Writer$",Writer)
TempletContent=replace(TempletContent,"$Content$",content)
TempletContent=replace(TempletContent,"$Id$",id)
TempletContent=replace(TempletContent,"$Classid$",classid)
TempletContent=replace(TempletContent,"$ClassName$",ClassName)
TempletContent=replace(TempletContent,"$Join_Record$",Join_Record) '相关记录
End Function
'***********************************************
'函数名：JoinChar
'作 用：向地址中加入 ? 或 &
'参 数：strUrl ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?")1 then
if InStr(strUrl,"&")
"
if ShowTotal=true then
strTemp=strTemp & "共 " & totalnumber & " " & strUnit & " "
end if
strUrl=JoinChar(sfilename)
if CurrentPage<2 then
strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "首页 "
strTemp=strTemp & "上一页 "
end if
if n-currentpage<1 then
strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "下一页 "
strTemp=strTemp & "尾页"
end if
strTemp=strTemp & " 页次：" & CurrentPage & "/" & n & "页 "
strTemp=strTemp & " " & maxperpage & "" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到："
end if
strTemp=strTemp & "
"
response.write strTemp
End Sub
'***********************************************
'过程名：showpage
'作 用：显示“上一页 下一页”等信息
'参 数：sfilename ----链接地址
' totalnumber ----总数量
' maxperpage ----每页数量
' ShowTotal ----是否显示总数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
' strUnit ----计数单位
'***********************************************
sub showpageback(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit)
dim n, i,strTemp,strUrl
if totalnumber mod maxperpage=0 then
n= totalnumber \ maxperpage
else
n= totalnumber \ maxperpage+1
end if
strTemp= "
"
if ShowTotal=true then
strTemp=strTemp & "共 " & totalnumber & " " & strUnit & " "
end if
strUrl=JoinChar(sfilename)
if CurrentPage<2 then
strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "首页 "
strTemp=strTemp & "上一页 "
end if
if n-currentpage<1 then
strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "下一页 "
strTemp=strTemp & "尾页"
end if
strTemp=strTemp & " 页次：" & CurrentPage & "/" & n & "页 "
strTemp=strTemp & " " & maxperpage & "" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到："
end if
strTemp=strTemp & "
"
response.write strTemp
End Sub
'***********************************************
'过程名：Show_Page
'作 用：显示“上一页 下一页”等信息
'参 数：sfilename ----链接地址
' totalnumber ----总数量
' maxperpage ----每页数量
' ShowTotal ----是否显示总数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
' strUnit ----计数单位
'***********************************************
Sub Show_Page(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit,CurrentPage)
dim AllPage,i,ShowText
if totalnumber mod maxperpage=0 then
AllPage = totalnumber \ maxperpage
else
AllPage = totalnumber \ maxperpage+1
end if
if sfilename="" then
TheUrl="?page="
else
TheUrl=sfilename&"&page="
end if
ShowCount=4
if AllPage>8 then
If (AllPage-CurrentPage)>=ShowCount and CurrentPage>0 then
if CurrentPage<=ShowCount then
for i=1 to ShowCount+1
If i<>CurrentPage Then
ShowText=ShowText & "
"
End If
next
end if
ShowText=FirstText&ShowText&EndText
if CurrentPage-1>0 then
ShowText="
"&ShowText
end if
if CurrentPage+1<=AllPage then
ShowText=ShowText&"
"
End if
ShowText="
"&ShowText & "
"
if AllPage>1 then
response.Write ShowText
end if
End Sub
'**************************************************
'函数名：infotime
'作 用：格式年月日
'**************************************************
function infotime(a)
dim monthstr,daystr,datestr
monthstr="" :daystr=""
if len(month(a))=1 then
monthstr="0"&month(a)
else
monthstr=month(a)
end if
if len(day(a))=1 then
daystr="0"&day(a)
else
daystr=day(a)
end if
datestr=year(a)&"-"&monthstr&"-"&daystr
response.write(datestr)
end function
'**************************************************
'函数名：infotime_F,带字符
'作 用：格式年月日
'**************************************************
function infotimeStr(datetime,flag)
dim monthstr,daystr,datestr
monthstr="" :daystr=""
if len(month(datetime))=1 then
monthstr="0"&month(datetime)
else
monthstr=month(datetime)
end if
if len(day(datetime))=1 then
daystr="0"&day(datetime)
else
daystr=day(datetime)
end if
datestr=year(datetime)&flag&monthstr&flag&daystr
response.write(datestr)
end function
Sub CheckOutUrl()
On Error Resume Next
Dim server_v1, server_v2
server_v1 = Replace(LCase(Trim(Request.ServerVariables("HTTP_REFERER"))), "http://", "")
server_v2 = LCase(Trim(Request.ServerVariables("SERVER_NAME")))
If server_v1 <> "" And Left(server_v1, Len(server_v2)) <> server_v2 Then
Response.Write("请不要从外网跨站提交数据到本站！！！")
Response.End()
End If
End Sub
Function BuildFile(ByVal sFile, ByVal sContent)
On Error Resume Next
Dim oFSO, oStream
If CacheConfig(24) = 1 Then
Set oFSO = server.CreateObject(CacheCompont(1))
' If Is_Debug=1 Then Response.Write sFile
' If Is_Debug=1 Then Response.Write sContent
Set oStream = oFSO.CreateTextFile(sFile,True)
oStream.Write sContent
oStream.Close
'增加对特殊字符的保护
If Err.Number<>0 Then
Set oStream = server.CreateObject(CacheCompont(2))
With oStream
.Type = 2
.Mode = 3
.open
'.Charset = "utf-8"
.Charset = "gb2312"
.Position = oStream.size
.WriteText = sContent
.SaveToFile sFile, 2
.Close
End With
Err.Clear
End If
Set oStream = Nothing
Set oFSO = Nothing
Else
Set oStream = server.CreateObject(CacheCompont(2))
With oStream
.Type = 2
.Mode = 3
.open
'.Charset = "utf-8"
.Charset = "gb2312"
.Position = oStream.size
.WriteText = sContent
.SaveToFile sFile, 2
.Close
End With
Set oStream = Nothing
End If
End Function
'取网页数据
Function GetHttp(url)
Dim Retrieval,GetBody
Set Retrieval = Server.CreateObject("MSXML2.serverXMLHTTP") '//把单词拆开防止杀毒软件误杀
Retrieval.Open "GET",url,false
Retrieval.setRequestHeader "Content-Type","application/x-www-form-urlencoded"
Retrieval.Send
GetBody=Retrieval.ResponseBody
GetHttp=BytesToBstr(GetBody)
Set Retrieval = Nothing
End function
'二进制转文本
Function BytesToBstr(body)
Dim objstream
Set objstream = CreateObject("Ado" & "db.Str" & "eam") '//把单词拆开防止杀毒软件误杀
objstream.Type = 1
objstream.Mode =3
objstream.Open
objstream.Write body
objstream.Position = 0
objstream.Type = 2
objstream.Charset = "GB2312"
BytesToBstr = objstream.ReadText
objstream.Close
set objstream = Nothing
End function
'------------------------WriteToHtml--------------------
Function WriteToHtml(Fpath,Templet)
dim fs,f
'On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(Fpath, True)
f.write(Templet)
f.close
Set f = nothing
Set fs = nothing
if err <> 0 then
WriteToHtml = false
else
'call ConnectionDatabase()
'sql="update tcarindex set turl='"&dbUrl&"' where CarID="&CarID
'conn.execute(sql)
'sql="update tcarweb set turl='"&dbUrl&"' where carid="&CarID
'conn.execute(sql)
'call closeConn()
WriteToHtml = true
end if
End function
'用CDOnts组件发邮件
Function SendCDOMail(Email,Topic,TextBody)
'dim objCDOMail
'Set objCDOMail = Server.CreateObject("CDONTS.NewMail")
'objCDOMail.From ="cs@tallzhi.com" '改为你的邮箱
'objCDOMail.To = Email
'objCDOMail.Subject = Topic
'objCDOMail.BodyFormat=0
'objCDOMail.MailFormat=0
'objCDOMail.Body = TextBody
'objCDOMail.Send
'Set objCDOMail = Nothing
'SendCDOMail = 1
dim Mailsend
set Mailsend = Server.CreateObject("easymail.Mailsend")
Dim Tid,Un
Un = "cs@tallzhi.com" '您的邮件服务器登录名，不需要密码
Dim EI
Set EI = server.CreateObject("easymail.Users")
Tid = EI.Login(un)
Set EI = Nothing
Mailsend.createnew Un,Tid '邮箱账号,临时ID
Mailsend.CharSet = "gb2312" '编码
Mailsend.MailName = "Http://www.tallzhi.com(淘智网)" '发件人名
Mailsend.EM_BackAddress = "" '邮件回复地址
Mailsend.EM_Bcc = "" '暗送地址
Mailsend.EM_Cc = "" '抄送地址
Mailsend.EM_OrMailName = "" '原邮件名
Mailsend.EM_Priority = "Normal" '邮件重要度
Mailsend.EM_ReadBack = false '是否读取确认,挂号信(限本系统内用户)
Mailsend.EM_SignNo = -1 '使用签名的序号
Mailsend.EM_Subject = Topic '主题
'Mailsend.EM_Text = TextBody '内容
Mailsend.EM_HTML_Text = TextBody 'HTML邮件内容
Mailsend.useRichEditer = true '发送的是否为HTML格式邮件
Mailsend.EM_TimerSend = "" '定时发送的时间
Mailsend.EM_To = Email '收件人地址
Mailsend.ForwardAttString = "" '转发邮件时的原附件
Mailsend.AddFromAttFileString = "" '添加自网络存储中的文件名
Mailsend.SystemMessage = false '是否是系统邮件
Mailsend.SendBackup = false '是否保存发送邮件
If Mailsend.Send() = false Then
SendEasyMail = 0
Else
SendEasyMail = 1
End If
Set Mailsend = nothing
End Function
function Delhtml(str)
dim re
Set re=new RegExp
re.IgnoreCase =true
re.Global=True
re.Pattern="(\<.[^\<]*\>)"
str=re.replace(str," ")
re.Pattern="(\<\/[^\<]*\>)"
str=re.replace(str," ")
Delhtml=str
set re=nothing
end function
function DecodeUrl(str)
dim re
Set re = New RegExp
re.Pattern = "(http\:\/\/|^http\:\/\/)([\w-]+\.+[\w-]+\.+[\w-]+\.+[\w-]+|[\w-]+\.+[\w-]+\.+[\w-]+)(/[\w-./?%&=]*)?"
re.Global = true
re.IgnoreCase = true
str = re.Replace(str,"$1$2$3")
DecodeUrl = str
end function
Function GetUrl()
Dim ScriptAddress, M_ItemUrl, M_item
ScriptAddress = CStr(Request.ServerVariables("SCRIPT_NAME")) '取得当前地址
M_ItemUrl = ""
If (Request.QueryString <> "") Then
ScriptAddress = ScriptAddress & "?"
For Each M_item In Request.QueryString
If InStr(page,M_Item)=0 Then
M_ItemUrl = M_ItemUrl & M_Item &"="& Server.URLEncode(Request.QueryString(""&M_Item&"")) & "&"
End If
Next
end if
GetUrl = ScriptAddress & M_ItemUrl
End Function
Function NewSendMail(Email,Topic,TextBody)
dim objCDOMail
Set objCDOMail = Server.CreateObject("CDONTS.NewMail")
objCDOMail.From ="cs@tallzhi.com" '改为你的邮箱
objCDOMail.To = Email
objCDOMail.Subject = Topic
objCDOMail.BodyFormat=0
objCDOMail.MailFormat=0
objCDOMail.Body = TextBody
objCDOMail.Send
Set objCDOMail = Nothing
SendCDOMail = 1
End Function
'过滤脚本
Function ClearScript(Str)
Set re = New RegExp
re.Pattern = "(<)([script]*)(>)"'(*)(<\/)(*script)(>)
re.Global = true
re.IgnoreCase = true
str = re.Replace(str,"<$2>")
ClearScript=str
End Function
function IsNumeric_Request(str)
dim values
values=request(str)
if not IsNumeric(values) then
Jstop("非法操作")
Else
IsNumeric_Request=values
End if
end function
function encodestr(str)
if str<>"" then
str=trim(str)
str=replace(str,"<","<")
str=replace(str,">",">")
str=replace(str,"'","""")
str=replace(str,vbCrLf&vbCrlf,"
"
case 2
Response.Write " 
"
case 1
Response.Write " 
"
End Select
End Function
Dim xing1,xing2,xing3,xing4,xing5,xing6,xing7,xing8,xing11,xing21,xing31,xing41,xing51,xing71
'星级设置
xing1="9"
xing2="50"
xing3="100"
xing4="200"
xing5="500"
xing6="900"
xing7="1800"
xing8="3000"
xing11="49"
xing21="99"
xing31="199"
xing41="499"
xing51="899"
xing6="900"
xing71="1799"
Function getlen(Str)
'取字符串长度，中文为两个字节
Dim P_Len, XX
P_Len = 0
getlen = 0
If Not IsNull(Str) And Str <> "" Then
P_Len = Len(Str)
For XX = 1 To P_Len
If Asc(Mid(Str, XX, 1)) < 0 Then
getlen = CLng(getlen) + 2
Else
getlen = CLng(getlen) + 1
End If
Next
End If
End Function
'================================================
'函数名：strLength
'作 用：计字符串长度
'参 数：str ----字符串
'================================================
Public Function strLength(ByVal str)
On Error Resume Next
If IsNull(str) Or str = "" Then
strLength = 0
Exit Function
End If
Dim WINNT_CHINESE
WINNT_CHINESE = (Len("例子") = 2)
If WINNT_CHINESE Then
Dim l, t
Dim i, c
l = Len(str)
t = l
For i = 1 To l
c = Asc(Mid(str, i, 1))
If c < 0 Then c = c + 65536
If c > 255 Then t = t + 1
Next
strLength = t
Else
strLength = Len(str)
End If
End Function
Function FilterString(ByVal strWord, ByVal intByteLength)
If strWord <> "" Then
dim HtmlStr
HtmlStr = strWord
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, """", Chr(34))
HtmlStr = Replace(HtmlStr, "'", Chr(39))
HtmlStr = Replace(HtmlStr, "{", Chr(123))
HtmlStr = Replace(HtmlStr, "}", Chr(125))
HtmlStr = Replace(HtmlStr, "$", Chr(36))
HtmlStr = Replace(HtmlStr, vbCrLf, "")
HtmlStr = Replace(HtmlStr, "====", "")
HtmlStr = Replace(HtmlStr, "----", "")
HtmlStr = Replace(HtmlStr, "////", "")
HtmlStr = Replace(HtmlStr, "\\\\", "")
HtmlStr = Replace(HtmlStr, "####", "")
HtmlStr = Replace(HtmlStr, "@@@@", "")
HtmlStr = Replace(HtmlStr, "****", "")
HtmlStr = Replace(HtmlStr, "~~~~", "")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[br\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "\[align=right\](.*)\[\/align\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "<(.[^>]*)>"
HtmlStr = re.Replace(HtmlStr, "")
Set re = Nothing
HtmlStr = Replace(HtmlStr, ">", ">")
HtmlStr = Replace(HtmlStr, "<", "<")
If strLength(HtmlStr) <= intByteLength Then
FilterString = HtmlStr
Else
Dim i
Dim intLength
Dim strChar
Dim bytChar
intLength = 0
For i = 1 to Len(HtmlStr)
strChar = Mid(HtmlStr, i, 1)
bytChar = Asc(Mid(HtmlStr, i, 1))
If bytChar < 0 or bytChar > 255 Then
intLength = intLength + 2
Else
intLength = intLength + 1
End If
If intLength > intByteLength Then Exit For
FilterString = FilterString & strChar
Next
'FilterString = FilterString & String(intPadDotAmount, ".")
FilterString = FilterString & "..."
End If
Else
FilterString = ""
End If
End Function
Function CutString(ByVal strWord, ByVal intByteLength)
If strWord <> "" Then
dim HtmlStr
HtmlStr = strWord
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, " ", "")
HtmlStr = Replace(HtmlStr, """", Chr(34))
HtmlStr = Replace(HtmlStr, "'", Chr(39))
HtmlStr = Replace(HtmlStr, "{", Chr(123))
HtmlStr = Replace(HtmlStr, "}", Chr(125))
HtmlStr = Replace(HtmlStr, "$", Chr(36))
HtmlStr = Replace(HtmlStr, vbCrLf, "")
HtmlStr = Replace(HtmlStr, "====", "")
HtmlStr = Replace(HtmlStr, "----", "")
HtmlStr = Replace(HtmlStr, "////", "")
HtmlStr = Replace(HtmlStr, "\\\\", "")
HtmlStr = Replace(HtmlStr, "####", "")
HtmlStr = Replace(HtmlStr, "@@@@", "")
HtmlStr = Replace(HtmlStr, "****", "")
HtmlStr = Replace(HtmlStr, "~~~~", "")
Set re = New RegExp
re.IgnoreCase = True
re.Global = True
re.Pattern = "\[br\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "\[align=right\](.*)\[\/align\]"
HtmlStr = re.Replace(HtmlStr, "")
re.Pattern = "<(.[^>]*)>"
HtmlStr = re.Replace(HtmlStr, "")
Set re = Nothing
HtmlStr = Replace(HtmlStr, ">", ">")
HtmlStr = Replace(HtmlStr, "<", "<")
If strLength(HtmlStr) <= intByteLength Then
CutString = HtmlStr
Else
Dim i
Dim intLength
Dim strChar
Dim bytChar
intLength = 0
For i = 1 to Len(HtmlStr)
strChar = Mid(HtmlStr, i, 1)
bytChar = Asc(Mid(HtmlStr, i, 1))
If bytChar < 0 or bytChar > 255 Then
intLength = intLength + 2
Else
intLength = intLength + 1
End If
If intLength > intByteLength Then Exit For
CutString = CutString & strChar
Next
'CutString = CutString & String(intPadDotAmount, ".")
'CutString = CutString & "..."
End If
Else
CutString = ""
End If
End Function
function forprice(snum)
if not isnumeric(snum) then forprice=0
if snum<1 then
forprice=cstr(0&snum)
forprice=replace(forprice,"00","0")
forprice=replace(forprice,"0.00","0")
forprice=replace(forprice,"0.0","0")
else
forprice=snum
end if
end function
function checkStr(str)
str = replace(str," ","")
str = replace(str,",","，")
str = replace(str,"'","”")
str = replace(str,"<","<")
str = replace(str,">",">")
str = replace(str,";","；")
checkStr = str
end function
TaskSiteUrl="http://www.taskba.cn"
KillWordString=""
Call Open_Conn(Conn,Connstr)
Set Rs = Server.CreateObject("ADODB.Recordset")
strSQL = "SELECT S_KillWords FROM B_System"
rs.Open strSQL,conn,1,1
If not Rs.Eof Then
KillWordString=Rs(0)
End If
Rs.Close
Set Rs=Nothing
Call End_Conn(Conn)
Function KillWord(strContent)
KillWordArray=Split(KillWordString, "|")
For i=0 To Ubound(KillWordArray)
strContent = Replace(strContent,KillWordArray(i),"***")
Next
KillWord=strContent
End Function
Dim BannedText,BannedHtmlEvent,BannedHtmlLabel
BannedText= "你妈的|吃屎|做爱"
BannedHtmlEvent="javascript:|onerror|onload|onmouseover"
BannedHtmlLabel="javascript:|onerror|onload|onmouseover"
''''''''''''''''''''''''''''''''''''
function HTMLEncode(fString)
fString=Server.HtmlEncode(fString)
fString=Replace(fString,"&","&")'
fString=Replace(fString,"\","\")
fString=Replace(fString,"--","--")
fString=Replace(fString,CHR(9)," ")
fString=Replace(fString,CHR(10),"$1:
