<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%
'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'公示期天数
%>
<%
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
function FilterString(str,snum)
'截取字符串中指定长度字符
str1=str
str2=""
str2len=0
for i=1 to len(str1)
if asc(mid(str1,i,1))<0 then
if str2="" then
str2=mid(str1,i,1)
str2len=str2len+2
else
if str2len
<%
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,"
")
str=replace(str,vbCrLf," ")
encodestr=replace(str," "," ")
end if
end function
Function Jmail(mailTo,mailTopic,mailBody,mailCharset,mailContentType)
'--------------------------------------------------------------------
'JMail
'--------------------------------------------------------------------
'入口参数：
' mailTo 收件人email地址
' mailTopic 邮件主题
' mailBody 邮件正文(内容)
' mailCharset 邮件字符集，例如GB2312或US-ASCII
' mailContentType 邮件正文格式，例如text/plain或text/html
'返回值：
' 字符串，发送成功后返回OK，不成功返回错误信息
'使用方法：
' 1)设置好常量，即以Const开头的变量
' 2)使用类似如下代码发信
'Dim SendStat
'SendStat = Jmail("aa@163.com","测试Jmail","这是一封 测试信！","GB2312","text/html")
'Response.Write SendStat
'--------------------------------------------------------------------
'***************根据需要设置常量开始*****************
Dim ConstFromNameCn,ConstFromNameEn,ConstFrom,ConstMailDomain,ConstMailServerUserName,ConstMailServerPassword
ConstFromNameCn = "淘智网"'发信人中文姓名(发中文邮件的时候使用)，例如'张三'
ConstFromNameEn = "service"'发信人英文姓名(发英文邮件的时候使用)，例如'zhangsan'
ConstFrom = "service@tallzhi.com"'发信人邮件地址，例如'zhangsan@163.com'
ConstMailDomain = "mail.tallzhi.com"'smtp服务器地址，例如smtp.163.com
ConstMailServerUserName = "service@tallzhi.com"'smtp服务器的信箱登陆名，例如'zhangsan'。注意要与发信人邮件地址一致！
ConstMailServerPassword = "#)!$$#@!"'smtp服务器的信箱登陆密码
'***************根据需要设置常量结束*****************
'-----------------------------以下内容无需改动------------------------------
On Error Resume Next
Dim myJmail
Set myJmail = Server.CreateObject("JMail.Message")
myJmail.Logging = True'记录日志
myJmail.ISOEncodeHeaders = False'邮件头不使用ISO-8859-1编码
myJmail.ContentTransferEncoding = "base64"'邮件编码设为base64
myJmail.AddHeader "Priority","3"'添加邮件头,不要改动！
myJmail.AddHeader "MSMail-Priority","Normal"'添加邮件头,不要改动！
myJmail.AddHeader "Mailer","Microsoft Outlook Express 6.00.2800.1437"'添加邮件头,不要改动！
myJmail.AddHeader "MimeOLE","Produced By Microsoft MimeOLE V6.00.2800.1441"'添加邮件头,不要改动！
myJmail.Charset = mailCharset
myJmail.ContentType = mailContentType
If UCase(mailCharset) = "GB2312" Then
myJmail.FromName = ConstFromNameCn
Else
myJmail.FromName = ConstFromNameEn
End If
myJmail.From = ConstFrom
myJmail.Subject = mailTopic
myJmail.Body = mailBody
myJmail.AddRecipient mailTo
myJmail.MailDomain = ConstMailDomain
myJmail.MailServerUserName = ConstMailServerUserName
myJmail.MailServerPassword = ConstMailServerPassword
myJmail.Send ConstMailDomain
myJmail.Close
Set myJmail=nothing
If Err Then
Jmail=Err.Description
Err.Clear
Else
Jmail="OK"
End If
On Error Goto 0
End Function
'过滤javascript
function movejs(str)
dim objregexp,str1,a
set objregexp=new regexp
objregexp.ignorecase =true
objregexp.global=true
objregexp.pattern="\"
a=objregexp.replace(str,"")
objregexp.pattern="\<[^\<]+>"
movejs=objregexp.replace(a,"")
end function
'过滤html标签只剩
function filterhtml(byval fstring)
if isnull(fstring) or trim(fstring)="" then
filterhtml=""
exit function
end if
fstring = replace(fstring, " ", "[br]")
fstring = replace(fstring, " ", "[br]")
'过滤html标签
dim re
set re = new regexp
re.ignorecase=true
re.global=true
re.pattern="<(.+?)>"
fstring = re.replace(fstring, "")
set re=nothing
fstring = replace(fstring, "[br]", " ")
filterhtml = fstring
end function
%>
<%
'---------------
'函数作用：计算某个字符在某个字符串中出现的次数
'作者：洪泽华
'2007-8-24
'---------------
Function CountChar(SearchString,SearchChar)
dim Seat,Count,i
Seat=0
Coun=0
IsFind=0
If Len(SearchString)>1 Then
For i=1 To Len(SearchString)
IsFind=Instr(Seat+1,SearchString,SearchChar)
If IsFind>0 Then
Seat=IsFind
Coun=Coun+1
i=Seat
Else
CountChar=Coun
Exit Function
End If
Next
End If
CountChar=Coun
End Function
%>
<%Dim Homepage:Homepage = "http://www.tallzhi.com"%>
<%
'on error resume next
Call Open_Conn(Conn,Connstr) '打开数据库连接
Dim strCurrentDomain,shopid
strCurrentDomain=trim(request.serverVariables("SERVER_NAME")) '获取域名
strCurrentDomain=checksqlstr(strCurrentDomain)
shopid = checkint(request("shopid"),0)
if shopid>0 then
call shengchengid(shopid)
response.redirect "/shop/"&shopid
end if
if shopid=0 then '生成店铺文件夹后加上的判断
dim http_referer,poz,getstr
http_referer=lcase(Request.ServerVariables("Script_Name"))
http_referer=replace(http_referer,"/shop/","")
poz=instr(http_referer,"/")
if poz>0 then
getstr=left(http_referer,poz-1)
shopid=checkint(getstr,0)
end if
end if
if shopid>0 then
elseif strCurrentDomain <>"www.tallzhi.com" and strCurrentDomain <>"www.tallzhi.net" and strCurrentDomain<>"tallzhi.tallzhi.com" and strCurrentDomain<>"tzuser05" then
set rsu=conn.execute("select U_id from B_Userurl inner join b_userinfo R_username=U_username where R_home='"&strCurrentDomain&"'")
if not rsu.eof then
shopid = rsu(0)
else
Call JsAlertAndGoto("温馨提示：二级域名对应的淘智店铺不存在！","/index.shtml")
end if
rsu.close
set rsu=nothing
elseif checkint(request.Cookies("mytallzhi")("myshopid"),-1)>0 then
shopid=checkint(request.Cookies("mytallzhi")("myshopid"),-1)
else
'Jstop("温馨提示：店铺不存在！")
end if
dim Shop_Username,S_ShopGonggao,S_logo,S_IsOk,U_RegTime,S_ShopInfo
if shopid>0 then
call shengchengid(shopid)
set rsuser = conn.execute("select * from B_Userinfo where U_id='"&shopid&"'")
if rsuser.eof then
'Jstop("温馨提示：店铺不存在！")
Else
Shop_Username=rsuser("U_Username")
name2=rsuser("U_NName")
tel=rsuser("U_Tel")
mail=rsuser("U_Email")
dizhi=rsuser("U_Address")
xb=rsuser("U_Sex")
img=rsuser("U_Img")
xinyong=rsuser("U_credit")
shopname=rsuser("S_ShopName")
id = rsuser("U_id")
oicq=rsuser("U_QQ")
MiShuQQ = rsuser("U_MiShuQQ")
MiShuMSN= rsuser("U_MiShuMSN")
MiShuWangwang= rsuser("U_MiShuWangwang")
Wangwang=rsuser("U_Wangwang")
MSN = rsuser("U_MSN")
S_ShopInfo = rsuser("S_ShopInfo")
ShopKeyword = rsuser("S_ShopKeyword")
info = rsuser("U_info")
if info = "" then info = "暂无介绍"
Out_HonorUrl = rsuser("U_HonorUrl")
PicField = rsuser("U_PicField")
S_ShopGonggao = rsuser("S_ShopGonggao")
S_logo = rsuser("S_logo")
S_IsOk = rsuser("S_IsOk")
U_RegTime = rsuser("U_RegTime")
rsuser.close
set rsuser=nothing
Dim ArrSex(1)
ArrSex(0) = "女"
ArrSex(1) = "男"
TheDay=request("TheDay")
if TheDay="" then TheDay=365
if S_IsOk=1 Then Jstop("温馨提示：该店已关闭！")
conn.execute("Update B_Userinfo set S_Hit=S_Hit+1 where U_id="&shopid&"")
End If
End If
Function VisitAdd(ShopID,MyUserName)
Dim Rs,Sql,IsExist,Rs1,Ip
IsExist=0
Set Rs=Server.CreateObject("Adodb.Recordset")
Sql="Select Top 10 L_UserName,L_VisitTime,L_UID,L_NName,L_IP,L_ID From B_LatelyVisit Where L_ShopID="&ShopID&" Order By L_VisitTime Desc"
Rs.Open Sql,Conn,1,2
Do Until Rs.Eof
If Rs(0)=MyUserName Then
Conn.Execute("Update B_LatelyVisit Set L_VisitTime='"&Now()&"' Where L_ID="&Rs("L_ID"))
IsExist=1
End If
Rs.MoveNext
Loop
Rs.Close
Set Rs=Nothing
If IsExist=0 Then
Set Rs1=Conn.Execute("Select U_ID,U_NName From B_UserInfo Where U_UserName='"&MyUserName&"'")
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" then
Ip=Request.ServerVariables("REMOTE_ADDR")
Else
Ip=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
If Rs1(0)<>ShopID Then
Conn.Execute("Insert InTo B_LatelyVisit(L_UserName,L_IP,L_UID,L_NName,L_ShopID)Values('"&MyUserName&"','"&IP&"',"&Rs1(0)&",'"&Rs1(1)&"',"&ShopID&")")
End If
End If
VisitAdd=IsExist
End Function
Function BlogClassName(ID)
Dim Rs
If ID="0" Or ID="" Then
BlogClassName="无分类"
Exit Function
Else
Set Rs=Conn.Execute("Select BC_ClassName From B_UserBlogClass Where BC_ID="&ID)
If Rs.Eof Then
BlogClassName="无分类"
Exit Function
Else
BlogClassName=Rs(0)
Exit Function
End If
End If
End Function
%>
<%Call Open_Conn(Conn,Connstr)%>
<%=shopname%>_淘智网
<%
Dim MyUrl,rs_url
set rs_url=conn.execute("select R_home from B_UserUrl where R_Username='"&Shop_Username&"'")
If Not rs_url.Eof Then
MyUrl="http://"&rs_url(0)
Else
MyUrl=""
End If
rs_url.Close
Set rs_url = Nothing
%>
<%
If Session("TallZhiUserName")<>"" Then
IsExist=VisitAdd(shopid,Session("TallZhiUserName"))
End If
%>
<%set rs_A=conn.execute("select U_Prname,U_Ciname,U_BuyCredit from B_UserInfo where U_Username='"&Shop_Username&"'")%>
昵称：<%=name2%>
地区：<%=rs_A("U_Prname")&" "&rs_A("U_Ciname")%>
总销售/总购买：次/次
总收入/总消费：元/元
卖家平均满意度：%
买家平均满意度：%
开店时间：<%=formatdatetime(U_RegTime,1)%>
<%if oicq<>"" then%>
<%end if
if MSN <>"" Then%>
<%end if%>
<%if Wangwang <>"" Then%>
<%end if%>
短消息
店铺简介
<%
If S_ShopInfo="" then
Response.write "暂无介绍"
else
Response.write S_ShopInfo
end if
%>
智慧分类
全部类目 <%
Set rsN = Server.CreateObject("ADODB.Recordset")
sql="select * from user_proType where shopid="&shopid&" Order By id DESC"
rsN.open sql,conn,1,1
do while not rsN.eof
'统计
Uc=0
set rsc=conn.execute("select count(*) as c from B_Product where Userlb="&rsn("id")&"")
if not rsc.eof then
Uc=rsc("c")
end if
rsc.close
%>
" class="black01"> <%=rsn("Userlb")%>(<%=Uc%>)
<%
rsN.movenext
loop
rsN.close
%>
店主技能
<%
If info = "" Then info = "温馨提示：暂无介绍"
Response.Write(""&replace(info,chr(10)," ")&"")
%>
最新访客
读取中...
友情链接
淘智威客网
<%
Set rsN = Server.CreateObject("ADODB.Recordset")
sql="Select * From B_ShopLink where shopid="&shopid&" Order By SL_id DESC"
rsN.open sql,conn,1,1
If rsN.eof Then
else
do while not rsN.eof
%>
" target="_blank" title="<%=rsN("SL_name")%>"><%=rsN("SL_name")%>
<%
rsN.movenext
loop
rsN.close
End If
%>
<%
Function GetPhotoUrl(Url,n)
Dim ArrUrl
ArrUrl = split(Url,"@@@")
if (n-1)<=ubound(ArrUrl) then
If ArrUrl(n-1)<>"pic" then GetPhotoUrl = ArrUrl(n-1)
End If
End Function
%>
店铺公告
<%
If S_ShopGonggao = "" Then S_ShopGonggao = "温馨提示：暂无内容"
If GetStrLen(S_ShopGonggao)>160 Then%>
<%
Else
Response.Write(""&S_ShopGonggao&"")
End If
%>
店主推荐
<%
'取推荐的最新五条智慧服务
Dim Tempcontent,showcontent,position,Tempcontent_,iii
sql="select top 5 P_id,P_ProductName,P_Price,P_Content,P_Postdate,P_FilePath,P_FileName,P_IsEspecial,P_PriceBorn,P_Bnumber,P_SmallPic from B_Product inner join B_Userinfo on P_Username = U_Username where U_IsCert>0 and U_Username='"&Shop_Username&"' and user_tui=1 and P_IsTask=0 and P_Hidden=0 and P_IsOk=1 and P_Isdelete=0 order by P_Num Asc, user_tui desc,P_id desc"
'Response.Write(sql)
set rsN=server.createobject("adodb.recordset")
rsN.open sql,conn,1,1
%>
<%
'取推荐的最新五条智慧服务
sql="select top 5 P_id,P_ProductName,P_Price,P_Content,P_Postdate,P_FilePath,P_FileName,P_IsEspecial,P_PriceBorn,P_Bnumber,P_renqi from B_Product inner join B_Userinfo on P_Username = U_Username where U_IsCert>0 and U_Username='"&Shop_Username&"' and P_Hidden=0 and P_IsOk=1 and P_Isdelete=0 and P_istask=0 and P_TaskID=0 order by P_Num Asc, user_tui desc,P_id desc"
'Response.Write(sql)
set rsN=server.createobject("adodb.recordset")
rsN.open sql,conn,1,1
%>
<%
'取推荐的最新五条智慧服务
sql="select top 5 Q_id,Q_ProductName,Q_Price,Q_Content,Q_Postdate,Q_Hit from B_Require where Q_username='"&Shop_Username&"' and Q_IsDelete=0 order by Q_id desc"
set rsN=conn.execute(sql)
%>
<%
clog_Year=saferequest(Trim(Request.QueryString("log_Year")))
clog_Month=saferequest(Trim(Request.QueryString("log_Month")))
clog_Day=saferequest(Trim(Request.QueryString("log_Day")))
set rsboke=server.CreateObject("adodb.recordset")
sql="select * from B_UserBlog where B_IsDelete=0 and B_UserName='"&Shop_Username&"'"
if clog_Year<>"" then
sql=sql & " and B_PostYear="&clog_Year&""
end if
if clog_month<>"" then
sql=sql & " and B_PostMonth="&clog_month&""
end if
if clog_day<>"" then
sql=sql & " and B_PostDay="&clog_day&""
end if
if typeid<>"" then
sql=sql & " and B_typeid="&typeid&""
end if
sql=sql & " order by B_id desc"
rsboke.open sql,conn,1,1
if not rsboke.eof then
rsboke.pagesize=20
page=checkint(Request("page"),1)
if page="" or not isnumeric(page) then page=1
if page<1 then page=1
if cint(page)>rsboke.pagecount then page=rsboke.pagecount
rsboke.absolutepage=page
for LL=1 to rsboke.pagesize
'取评论次数
pl=0
set rsp=conn.execute("select count(*) as counts from B_BlogReply where R_Blogid="&rsboke("B_id"))
if not rsp.eof then
pl=rsp("counts")
end if
rsp.close
%>
<%
rsboke.movenext
if rsboke.eof then exit for
next
sRecordCount=rsboke.recordcount
sPageCount=rsboke.pagecount
PageName="Blog.asp?shopid="&shopid
end if
%>
"
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:
<%end if%>
总销售/总购买：次/次
<%end if%>
<%if Wangwang <>"" Then%>
全部类目
