📄 function.asp
字号:
<%
dim UserLogined,UserName,UserLevel,ChargeType,UserPoint,ValidDays,UserReceive,ValidDaysType
dim Action,FoundErr,ErrMsg,ComeUrl
dim strInstallDir,HtmlDir
dim strHTML
dim ObjInstalled_FSO,fso
dim strChannel,sqlChannel,rsChannel,ChannelName,ChannelShortName,ChannelDir,SheetName,ShowChannelName
dim EnableCheck,DefaultAddPurview,DefaultCommentPurview,ModuleType,ModuleName,Template_Index,UseCreateHTML
dim ShowMyStyle,ShowClassTreeGuide,ShowAllClass,DaysOfNew,HitsOfHot,MaxPerLine,DefaultSkinID,TopMenuType,ClassGuideType
ComeUrl=trim(request.ServerVariables("HTTP_REFERER"))
ObjInstalled_FSO=IsObjInstalled(objName_FSO)
if ObjInstalled_FSO=True then
set fso=Server.CreateObject(objName_FSO)
end if
Action=trim(request("Action"))
FoundErr=False
ErrMsg=""
if right(InstallDir,1)<>"/" then
strInstallDir=InstallDir & "/"
else
strInstallDir=InstallDir
end if
'**************************************************
'函数名：gotTopic
'作 用：截字符串，汉字一个算两个字符，英文算一个字符
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'**************************************************
function gotTopic(ByVal str,ByVal strlen)
if str="" then
gotTopic=""
exit function
end if
dim l,t,c, i,strTemp
str=replace(replace(replace(replace(str," "," "),""",chr(34)),">",">"),"<","<")
l=len(str)
t=0
strTemp=str
strlen=Clng(strLen)
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
strTemp=left(str,i)
exit for
end if
next
if strTemp<>str then
strTemp=strTemp & "…"
end if
gotTopic=replace(replace(replace(replace(strTemp," "," "),chr(34),"""),">",">"),"<","<")
end function
'**************************************************
'函数名：JoinChar
'作 用：向地址中加入 ? 或 &
'参 数：strUrl ----网址
'返回值：加了 ? 或 & 的网址
'**************************************************
function JoinChar(ByVal 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 ----计数单位
'返回值：“上一页 下一页”等信息的HTML代码
'**************************************************
function ShowPage(sFileName,TotalNumber,MaxPerPage,ShowTotal,ShowAllPages,strUnit)
dim TotalPage,strTemp,strUrl,i
if TotalNumber=0 or MaxPerPage=0 or isNull(MaxPerPage) then
ShowPage=""
exit function
end if
if totalnumber mod maxperpage=0 then
TotalPage= totalnumber \ maxperpage
else
TotalPage= totalnumber \ maxperpage+1
end if
if CurrentPage>TotalPage then CurrentPage=TotalPage
strTemp= "<table align='center'><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 CurrentPage>=TotalPage then
strTemp=strTemp & "下一页 尾页"
else
strTemp=strTemp & "<a href='" & strUrl & "page=" & (CurrentPage+1) & "'>下一页</a> "
strTemp=strTemp & "<a href='" & strUrl & "page=" & TotalPage & "'>尾页</a>"
end if
strTemp=strTemp & " 页次：<strong><font color=red>" & CurrentPage & "</font>/" & TotalPage & "</strong>页 "
strTemp=strTemp & " <b>" & maxperpage & "</b>" & strUnit & "/页"
if ShowAllPages=True then
strTemp=strTemp & " 转到第<input type='text' name='page' size='3' maxlength='5' value='" & CurrentPage & "' onKeyPress=""if (event.keyCode==13) window.location='" & strUrl & "page=" & "'+this.value;""'>页"
'strTemp=strTemp & " 转到：<select name='page' size='1' onchange=""javascript:window.location='" & strUrl & "page=" & "'+this.options[this.selectedIndex].value;"">"
'for i = 1 to TotalPage
' 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></table>"
ShowPage=strTemp
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
'**************************************************
'函数名：SendMail
'作 用：用Jmail组件发送邮件
'参 数：MailtoAddress ----收信人地址
' MailtoName -----收信人姓名
' Subject -----主题
' MailBody -----信件内容
' FromName -----发信人姓名
' MailFrom -----发信人地址
' Priority -----信件优先级
'返回值：错误信息
'**************************************************
function SendMail(MailtoAddress,MailtoName,Subject,MailBody,FromName,MailFrom,Priority)
on error resume next
Dim JMail
Set JMail=Server.CreateObject("JMail.Message")
if err then
SendMail= "<br><li>没有安装JMail组件</li>"
err.clear
exit function
end if
JMail.Charset="gb2312" '邮件编码
JMail.silent=true
JMail.ContentType = "text/html" '邮件正文格式
'JMail.ServerAddress=MailServer '用来发送邮件的SMTP服务器
'如果服务器需要SMTP身份验证则还需指定以下参数
JMail.MailServerUserName = MailServerUserName '登录用户名
JMail.MailServerPassWord = MailServerPassword '登录密码
JMail.MailDomain = MailDomain '域名（如果用“name@domain.com”这样的用户名登录时，请指明domain.com
JMail.AddRecipient MailtoAddress,MailtoName '收信人
JMail.Subject=Subject '主题
JMail.HMTLBody=MailBody '邮件正文（HTML格式）
JMail.Body=MailBody '邮件正文（纯文本格式）
JMail.FromName=FromName '发信人姓名
JMail.From = MailFrom '发信人Email
JMail.Priority=Priority '邮件等级，1为加急，3为普通，5为低级
JMail.Send(MailServer)
SendMail =JMail.ErrorMessage
JMail.Close
Set JMail=nothing
SendMail=""
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-----要过滤的字符
'返回值：过滤后的字符
'**************************************************
Function ReplaceBadChar(strChar)
If strChar = "" Then
ReplaceBadChar = ""
Else
ReplaceBadChar = Replace(Replace(Replace(Replace(Replace(Replace(Replace(strChar, "'", ""), "*", ""), "?", ""), "(", ""), ")", ""), "<", ""), ".", "")
End If
End Function
'**************************************************
'函数名：CheckUserLogined
'作 用：检查用户是否登录
'参 数：无
'返回值：True ----已经登录
' False ---没有登录
'**************************************************
function CheckUserLogined()
dim Logined,Password,rsLogin,sqlLogin
Logined=True
UserName=Request.Cookies("asp163")("UserName")
Password=Request.Cookies("asp163")("Password")
UserLevel=Request.Cookies("asp163")("UserLevel")
if UserName="" then
Logined=False
end if
if Password="" then
Logined=False
end if
if UserLevel="" then
Logined=False
UserLevel=9999
end if
if Logined=False then
CheckUserLogined=False
exit function
end if
username=replace(trim(username),"'","")
password=replace(trim(password),"'","")
UserLevel=Cint(trim(UserLevel))
set rsLogin=server.createobject("adodb.recordset")
'sqlLogin="select * from " & db_User_Table & " where LockUser<>" & PE_True_User & " and " & db_User_Name & "='" & username & "' and " & db_User_Password & "='" & password &"'"
sqlLogin="select * from " & db_User_Table & " where " & db_User_Name & "='" & username & "' and " & db_User_Password & "='" & password &"'"
rsLogin.open sqlLogin,Conn_User,1,1
if rsLogin.bof and rsLogin.eof then
Logined=False
else
if password<>rsLogin(db_User_Password) or UserLevel<rsLogin(db_User_UserLevel) then
Logined=False
elseif rsLogin("LockUser")=1 then
Logined=False
else
UserName=rsLogin(db_User_Name)
UserLevel=rsLogin(db_User_UserLevel)
ChargeType=rsLogin(db_User_ChargeType)
UserPoint=rsLogin(db_User_UserPoint)
if rsLogin(db_User_Valid_Num)=-1 then
ValidDaysType=0
ValidDays=0
else
ValidDaysType=1
if rsLogin(db_User_Valid_Unit)=1 then
ValidDays=rsLogin(db_User_Valid_Num)
elseif rsLogin(db_User_Valid_Unit)=2 then
ValidDays=rsLogin(db_User_Valid_Num)*30
elseif rsLogin(db_User_Valid_Unit)=3 then
ValidDays=rsLogin(db_User_Valid_Num)*365
end if
ValidDays=ValidDays-DateDiff("D",rsLogin(db_User_BeginDate),now())
end if
if SystemVersion = 3 then
if rsLogin("ArticlesReceive")="" or isnull(rsLogin("ArticlesReceive")) then
UserReceive=0
else
UserReceive=ubound(split(rsLogin("ArticlesReceive"),","))+1
end if
end if
end if
end if
rsLogin.close
set rsLogin=nothing
CheckUserLogined=Logined
end function
'**************************************************
'函数名：GetLevelName
'作 用：得到用户级别的名称
'参 数：UserLevel-----用户级别值
'返回值：用户级别名称
'**************************************************
function GetLevelName(UserLevel)
dim strLevelName,rsLevel
if UserLevel=5 then
GetLevelName="管理员"
elseif UserLevel=9999 then
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -