📄 function.asp
字号:
<%
Dim Action, FoundErr, ErrMsg, ComeUrl
Dim strInstallDir,InstallDir
Dim Site_Sn '定义系统识别码
ComeUrl = Trim(Request.ServerVariables("HTTP_REFERER"))
Action = Trim(Request("Action"))
FoundErr = False
ErrMsg = ""
If Right(InstallDir, 1) <> "/" Then
strInstallDir = InstallDir & "/"
Else
strInstallDir = InstallDir
End If
Site_Sn = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME") & InstallDir), "/", ""), ".", "")
'*************************************************
'函数名：gotTopic
'作 用：截字符串，汉字一个算两个字符，英文算一个字符
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function gotTopic(str,strlen)
if isnull(str) or str="" then
gotTopic=""
exit function
end if
dim l,t,c, i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
gotTopic=left(str,i) & "…"
exit for
else
gotTopic=str
end if
next
gotTopic=replace(replace(replace(replace(gotTopic," "," "),chr(34),"""),">",">"),"<","<")
end function
'*************************************************
'函数名：NogotTopic
'作 用：截字符串，汉字一个算两个字符，英文算一个字符,结尾没有三个点
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'*************************************************
function NogotTopic(str,strlen)
if str="" then
NogotTopic=""
exit function
end if
dim l,t,c, i
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
for i=1 to l
c=Abs(Asc(Mid(str,i,1)))
if c>255 then
t=t+2
else
t=t+1
end if
if t>=strlen then
NogotTopic=left(str,i)
exit for
else
NogotTopic=str
end if
next
NogotTopic=replace(replace(replace(replace(NogotTopic," "," "),chr(34),"""),">",">"),"<","<")
end function
'***********************************************
'函数名：JoinChar
'作 用：向地址中加入 ? 或 &
'参 数：strUrl ----网址
'返回值：加了 ? 或 & 的网址
'***********************************************
function JoinChar(strUrl)
if strUrl="" then
JoinChar=""
exit function
end if
if InStr(strUrl,"?")<len(strUrl) then
if InStr(strUrl,"?")>1 then
if InStr(strUrl,"&")<len(strUrl) then
JoinChar=strUrl & "&"
else
JoinChar=strUrl
end if
else
JoinChar=strUrl & "?"
end if
else
JoinChar=strUrl
end if
end function
'***********************************************
'过程名：showpage
'作 用：显示“上一页 下一页”等信息
'参 数：sfilename ----链接地址
' totalnumber ----总数量
' maxperpage ----每页数量
' ShowTotal ----是否显示总数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
' strUnit ----计数单位
' CurrentPage -----现在的页数
'........................................调用页面需要定义的
' CurrentPage=replacebadchar(request("page"))
' if CurrentPage="" then
' CurrentPage=1
' else if not IsNumeric(CurrentPage) then
' CurrentPage=1
' else if int(CurrentPage)<=0 then
' CurrentPage=1
' else
' CurrentPage=replacebadchar(request("page"))
' end if
' end if
' end if
' strFileName=""
' maxperpage=10
' rs.pagesize=MaxPerpage
' totalnumber=rs.recordcount
' if totalnumber mod maxperpage=0 then
' MaxPage= totalnumber \ MaxPerpage
' else
' MaxPage= totalnumber \ MaxPerpage+1
' end if
' if int(CurrentPage)>int(MaxPage) then
' CurrentPage=MaxPage
' else
' CurrentPage=CurrentPage
' end if
' Rs.absolutepage=CurrentPage
' for ni=1 to MaxPerpage
' if rs.eof then exit for
' call showpage(strFileName,totalnumber,MaxPerPage,flase,true,"条") //调用语句
'
'
'
'***********************************************
sub showpage(sfilename,totalnumber,maxperpage,ShowTotal,ShowAllPages,strUnit,CurrentPage)
dim n, i,strTemp,strUrl
if totalnumber mod maxperpage=0 then
n= totalnumber \ maxperpage
else
n= totalnumber \ maxperpage+1
end if
strTemp= "<table align='center'><form name='showpages' method='post' action='" & sfilename & "'><tr><td>"
if ShowTotal=true then
strTemp=strTemp & "共 <b>" & totalnumber & "</b> " & strUnit & " "
end if
strUrl=JoinChar(sfilename)
if CurrentPage<2 then
strTemp=strTemp & "首页 上一页 "
else
strTemp=strTemp & "<a href='" & strUrl & "page=1'>首页</a> "
strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage-1) & "'>上一页</a> "
end if
if n-currentpage<1 then
strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> "
strTemp=strTemp & "<a href='" & strUrl & "page=" & n & "'>尾页</a>"
end if
strTemp=strTemp & " 页次：<strong><font color=red>" & CurrentPage & "</font>/" & n & "</strong>页 "
strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到：<select name='page' size='1' onchange='javascript:submit()'>"
for i = 1 to n
strTemp=strTemp & "<option value='" & i & "'"
if cint(CurrentPage)=cint(i) then strTemp=strTemp & " selected "
strTemp=strTemp & ">第" & i & "页</option>"
next
strTemp=strTemp & "</select>"
end if
strTemp=strTemp & "</td></tr></form></table>"
response.write strTemp
end sub
'********************************************
'函数名：IsValidEmail
'作 用：检查Email地址合法性
'参 数：email ----要检查的Email地址
'返回值：True ----Email地址合法
' False ----Email地址不合法
'********************************************
function IsValidEmail(email)
dim names, name, i, c
IsValidEmail = true
names = Split(email, "@")
if UBound(names) <> 1 then
IsValidEmail = false
exit function
end if
for each name in names
if Len(name) <= 0 then
IsValidEmail = false
exit function
end if
for i = 1 to Len(name)
c = Lcase(Mid(name, i, 1))
if InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 and not IsNumeric(c) then
IsValidEmail = false
exit function
end if
next
if Left(name, 1) = "." or Right(name, 1) = "." then
IsValidEmail = false
exit function
end if
next
if InStr(names(1), ".") <= 0 then
IsValidEmail = false
exit function
end if
i = Len(names(1)) - InStrRev(names(1), ".")
if i <> 2 and i <> 3 then
IsValidEmail = false
exit function
end if
if InStr(email, "..") > 0 then
IsValidEmail = false
end if
end function
'***************************************************
'函数名：IsObjInstalled
'作 用：检查组件是否已经安装
'参 数：strClassString ----组件名
'返回值：True ----已经安装
' False ----没有安装
'***************************************************
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function
'**************************************************
'函数名：strLength
'作 用：求字符串长度。汉字算两个字符，英文算一个字符。
'参 数：str ----要求长度的字符串
'返回值：字符串长度
'**************************************************
function strLength(str)
ON ERROR RESUME NEXT
dim WINNT_CHINESE
WINNT_CHINESE = (len("中国")=2)
if WINNT_CHINESE then
dim l,t,c
dim i
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
end if
next
strLength=t
else
strLength=len(str)
end if
if err.number<>0 then err.clear
end function
'****************************************************
'函数名：SendMail
'作 用：用Jmail组件发送邮件
'参 数：ServerAddress ----服务器地址
' AddRecipient ----收信人地址
' Subject ----主题
' Body ----信件内容
' Sender ----发信人地址
'****************************************************
function SendMail(MailServerAddress,AddRecipient,Subject,Body,Sender,MailFrom)
on error resume next
Dim JMail
Set JMail=Server.CreateObject("JMail.SMTPMail")
if err then
SendMail= "<br><li>没有安装JMail组件</li>"
err.clear
exit function
end if
JMail.Logging=True
JMail.Charset="gb2312"
JMail.ContentType = "text/html"
JMail.ServerAddress=MailServerAddress
JMail.AddRecipient=AddRecipient
JMail.Subject=Subject
JMail.Body=MailBody
JMail.Sender=Sender
JMail.From = MailFrom
JMail.Priority=1
JMail.Execute
Set JMail=nothing
if err then
SendMail=err.description
err.clear
else
SendMail="OK"
end if
end function
'**************************************************
'过程名：WriteErrMsg
'作 用：显示错误提示信息
'参 数：无
'**************************************************
Sub WriteErrMsg()
Dim strErr
strErr = strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
strErr = strErr & "<link href='" & strInstallDir & "Admin/Admin_Style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbCrLf
strErr = strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf
strErr = strErr & " <tr align='center' class='title'><td height='22'><strong>错误信息</strong></td></tr>" & vbCrLf
strErr = strErr & " <tr class='tdbg'><td height='100' valign='top'><b>产生错误的可能原因：</b>" & ErrMsg & "</td></tr>" & vbCrLf
strErr = strErr & " <tr align='center' class='tdbg'><td>"
If ComeUrl <> "" Then
strErr = strErr & "<a href='javascript:history.go(-1)'><< 返回上一页</a>"
Else
strErr = strErr & "<a href='javascript:window.close();'>【关闭】</a>"
End If
strErr = strErr & "</td></tr>" & vbCrLf
strErr = strErr & "</table>" & vbCrLf
strErr = strErr & "</body></html>" & vbCrLf
Response.Write strErr
End Sub
'**************************************************
'过程名：WriteSuccessMsg
'作 用：显示成功提示信息
'参 数：无
'**************************************************
Sub WriteSuccessMsg(SuccessMsg)
Dim strSuccess
strSuccess = strSuccess & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
strSuccess = strSuccess & "<link href='" & strInstallDir & "Admin/Admin_Style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbCrLf
strSuccess = strSuccess & "<table cellpadding=2 cellspacing=1 border=0 width=400 class='border' align=center>" & vbCrLf
strSuccess = strSuccess & " <tr align='center' class='title'><td height='22'><strong>恭喜你！</strong></td></tr>" & vbCrLf
strSuccess = strSuccess & " <tr class='tdbg'><td height='100' valign='top'><br>" & SuccessMsg & "</td></tr>" & vbCrLf
strSuccess = strSuccess & " <tr align='center' class='tdbg'><td>"
If ComeUrl <> "" Then
strSuccess = strSuccess & "<a href='" & ComeUrl & "'><< 返回上一页</a>"
Else
strSuccess = strSuccess & "<a href='javascript:window.close();'>【关闭】</a>"
End If
strSuccess = strSuccess & "</td></tr>" & vbCrLf
strSuccess = strSuccess & "</table>" & vbCrLf
strSuccess = strSuccess & "</body></html>" & vbCrLf
Response.Write strSuccess
End Sub
'**************************************************
'函数名：ReplaceBadChar
'作 用：过滤非法的SQL字符
'参 数：strChar-----要过滤的字符
'返回值：过滤后的字符
'**************************************************
Public Function ReplaceBadChar(strChar)
If strChar = "" Or IsNull(strChar) Then
ReplaceBadChar = ""
Exit Function
End If
Dim strBadChar, arrBadChar, tempChar, i
strBadChar = "',%,^,&,?,(,),<,>,[,],{,},/,\,;,:,exists,select,update,insert,=," & Chr(34) & "," & Chr(0) & ""
arrBadChar = Split(strBadChar, ",")
tempChar = strChar
For i = 0 To UBound(arrBadChar)
tempChar = Replace(tempChar, arrBadChar(i), "")
Next
ReplaceBadChar = tempChar
End Function
'**************************************************
'函数名：GetRndPassword
'作 用：获取验证码
'参 数：PasswordLen-----验证码
'返回值：验证码
'**************************************************
Function GetRndPassword(PasswordLen)
Dim Ran, i, strPassword
strPassword = ""
For i = 1 To PasswordLen
Randomize
Ran = CInt(Rnd * 2)
Randomize
If Ran = 0 Then
Ran = CInt(Rnd * 25) + 97
strPassword = strPassword & UCase(Chr(Ran))
ElseIf Ran = 1 Then
Ran = CInt(Rnd * 9)
strPassword = strPassword & Ran
ElseIf Ran = 2 Then
Ran = CInt(Rnd * 25) + 97
strPassword = strPassword & Chr(Ran)
End If
Next
GetRndPassword = strPassword
End Function
'**************************************
' 处理 resquest.QueryString 接收的 ID
'**************************************
function replaceid(id)
TEMPid=replacebadchar(id)
if TEMPid="" then
TEMPid=1
else if not IsNumeric(TEMPid) then
TEMPid=1
else if int(TEMPid)<=0 then
TEMPid=1
else
TEMPid=replacebadchar(id)
end if
end if
end if
replaceid=TEMPid
end function
%>
<%
'******************************************
' 获得 小类 名称
'*******************************************
function smallClass(classid)
temp=classid
set scrs=server.CreateObject("adodb.recordset")
sql="select className from j_productsmallclass where delflag=false and id="&temp&""
scrs.open sql,conn,1,1
response.Write(scrs("classname"))
scrs.close
set scrs=nothing
end function
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -