📄 function.asp
字号:
'函数名：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
'****************************************************
'函数名：CreateMultiFolder
'作 用：创建多级目录，可以创建不存在的根目录
'参 数：要创建的目录名称，可以是多级
'返回逻辑值：True成功，False失败
'创建目录的根目录从当前目录开始
'****************************************************
Function CreateMultiFolder(ByVal CFolder)
Dim objFSO,PhCreateFolder,CreateFolderArray,CreateFolder
Dim i,ii,CreateFolderSub,PhCreateFolderSub,BlInfo
BlInfo = False
CreateFolder = CFolder
On Error Resume Next
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If Err Then
Err.Clear()
Exit Function
End If
CreateFolder = Replace(CreateFolder,"\","/")
If Left(CreateFolder,1)="/" Then
'CreateFolder = Right(CreateFolder,Len(CreateFolder)-1)
End If
If Right(CreateFolder,1)="/" Then
CreateFolder = Left(CreateFolder,Len(CreateFolder)-1)
End If
CreateFolderArray = Split(CreateFolder,"/")
For i = 0 to UBound(CreateFolderArray)
CreateFolderSub = ""
For ii = 0 to i
CreateFolderSub = CreateFolderSub & CreateFolderArray(ii) & "/"
Next
PhCreateFolderSub = Server.MapPath(CreateFolderSub)
'response.Write PhCreateFolderSub&"<br>"
If Not objFSO.FolderExists(PhCreateFolderSub) Then
objFSO.CreateFolder(PhCreateFolderSub)
End If
Next
If Err Then
Err.Clear()
Else
BlInfo = True
End If
Set objFSO=nothing
CreateMultiFolder = BlInfo
End Function
'**************************************************
'函数名：FSOFiledel
'作 用：使用FSO删除文件内容的函数
'参 数：filename ----文件名称
'返回值：文件内容
'**************************************************
function FSOFiledel(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
if objFSO.FileExists(Server.MapPath(filename)) = True Then
Set objCountFile = objFSO.GetFile(Server.MapPath(filename))
objCountFile.delete
Set objCountFile = Nothing
end if
Set objFSO = Nothing
End Function
'**************************************************
'函数名：FSOFileRead
'作 用：使用FSO读取文件内容的函数
'参 数：filename ----文件名称
'返回值：文件内容
'**************************************************
function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
'**************************************************
'函数名：FSOlinedit
'作 用：使用FSO读取文件某一行的函数
'参 数：filename ----文件名称
' lineNum ----行数
'返回值：文件该行内容
'**************************************************
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function
'**************************************************
'函数名：FSOlinewrite
'作 用：使用FSO写文件某一行的函数
'参 数：filename ----文件名称
' lineNum ----行数
' Linecontent ----内容
'返回值：无
'**************************************************
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function
'**************************************************
'函数名：FSOCopyFiles
'作 用：使用FSO复制文件
'参 数：TempSource ----文件名称
' TempEnd ----行数
'返回值：无
'**************************************************
Function FSOCopyFiles(TempSource,TempEnd)
TempSource=server.mappath(TempSource)
TempEnd=server.mappath(TempEnd)
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
IF FSO.FileExists(TempEnd) then
' FoundErr=True
' ErrCodes=ErrCodes & "<li>目标文件 <b>" & TempEnd & "</b> 已存在，请先删除!</li><br>"
Set FSO=Nothing
Exit Function
End IF
IF FSO.FileExists(TempSource) Then
Else
FoundErr=True
ErrCodes=ErrCodes & "<li>要复制的源文件 <b>"&TempSource&"</b> 不存在!</li><br>"
Set FSO=Nothing
Exit Function
End If
FSO.CopyFile TempSource,TempEnd
Set FSO=Nothing
End Function
'**************************************************
'函数名：ShowPage
'作 用：显示“上一页 下一页”等信息
'参 数：sFileName ----链接地址
' TotalNumber ----总数量
' MaxPerPage ----每页数量
' ShowTotal ----是否显示总数量
' ShowAllPages ----是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
' strUnit ----计数单位
'返回值：“上一页 下一页”等信息的HTML代码
'**************************************************
function ShowPage(sFileName,CurrentPage,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 class='form' type='text' name='page' size='3' maxlength='5' value='" & CurrentPage & "' onKeyPress=""if (event.keyCode==13) window.location='" & strUrl & "page=" & "'+this.value;""'>页"
end if
strTemp=strTemp & "</td></tr></table>"
ShowPage=strTemp
end function
'****************************************************
'过程名：WriteErrMsg
'作 用：显示错误提示信息
'参 数：无
'****************************************************
sub WriteErrMsg(errmsg)
dim strErr
strErr=strErr & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbcrlf
strErr=strErr & "<link href='css/main.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
strErr=strErr & "<table cellpadding=2 cellspacing=1 border=1 width=500 class='border' align=center bordercolor=#A4CEE4 bordercolordark=#FFFFFF>" & vbcrlf
strErr=strErr & " <tr align='center' class='xxxxxt'><td height='22' bgcolor=#588fc7><font color=#FFFFFF><b>错误信息</b></font></td></tr>" & vbcrlf
strErr=strErr & " <tr class='dt'><td height='100' valign='top'><b>产生错误的可能原因：</b>" & errmsg &"</td></tr>" & vbcrlf
strErr=strErr & " <tr align='center' class='dt'><td><a href='javascript:history.go(-1)'><< 返回上一页</a></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='css/main.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
strSuccess=strSuccess & "<table cellpadding=2 cellspacing=1 border=1 width=500 class='border' align=center bordercolor=#A4CEE4 bordercolordark=#FFFFFF>" & vbcrlf
strSuccess=strSuccess & " <tr align='center' class='xxxxxt'><td height='22' bgcolor=#588fc7><font color=#FFFFFF><b>恭喜你！</b></font></td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr class='dt'><td height='100' valign='top'><br>" & SuccessMsg &"</td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr align='center' class='dt'><td> </td></tr>" & vbcrlf
strSuccess=strSuccess & "</table>" & vbcrlf
strSuccess=strSuccess & "</body></html>" & vbcrlf
response.write strSuccess
end sub
'****************************************************
'函数名：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
end function
'**************************************************
'函数名：Checkreader
'作 用：检查用户是否设置了阅读状态
'参 数：无
'返回值：True ----设置
' False ---没有
'**************************************************
function Checkreader()
dim readered,a,b,c,d
readered=True
a=Request.Cookies("JsIce")("a")
b=Request.Cookies("JsIce")("b")
c=Request.Cookies("JsIce")("c")
d=Request.Cookies("JsIce")("d")
if a="" then
readered=False
end if
if b="" then
readered=False
end if
if c="" then
readered=False
end if
if d="" then
readered=False
end if
Checkreader=readered
end function
'**************************************************
'函数名：SaveCookie_JsIce
'作 用：保存阅读状态
'参 数：无
'**************************************************
sub SaveCookie_JsIce()
Response.Cookies("JsIce")("a")=a
Response.Cookies("JsIce")("b")=b
Response.Cookies("JsIce")("c")=c
Response.Cookies("JsIce")("d")=d
Response.Cookies("JsIce").Expires=Date+365
Response.Cookies("JsIce")("CookieDate") = CookieDate
end sub
function unhtmllist(content)
unhtmllist=content
if content <> "" then
unhtmllist=replace(unhtmllist,"'",""")
unhtmllist=replace(unhtmllist,chr(10),"")
unHtmllist=replace(unHtmllist,chr(13),"<br>")
end if
end function
function unhtmllists(content)
unhtmllists=content
if content <> "" then
unhtmllists=replace(unhtmllists,"""",""")
unhtmllists=replace(unhtmllists,"'",""")
unhtmllists=replace(unhtmllists,chr(10),"")
unHtmllists=replace(unHtmllists,chr(13),"<br>")
end if
end function
function htmllists(content)
htmllists=content
if content <> "" then
htmllists=replace(htmllists,"‘’","""")
htmllists=replace(htmllists,""","'")
htmllists=replace(htmllists,"<br>",chr(13)&chr(10))
end if
end function
function uhtmllists(content)
uhtmllists=content
if content <> "" then
uhtmllists=replace(uhtmllists,"""","‘’")
uhtmllists=replace(uhtmllists,"'",""")
uhtmllists=replace(uhtmllists,chr(10),"")
uHtmllists=replace(uHtmllists,chr(13),"<br>")
end if
end function
function unHtml(content)
unHtml=content
if content <> "" then
unHtml=replace(unHtml,"<p>",chr(13))
unHtml=replace(unHtml,"<br>",chr(13))
unHtml=replace(unHtml,"<","<")
unHtml=replace(unHtml,">",">")
unHtml=replace(unHtml,chr(34),""")
unHtml=replace(unHtml,chr(13),"<br>")
unhtml=replace(unhtml,chr(10),"")
unHtml=replace(unHtml,chr(32)," ")
unhtmlgl=split(lockComment,"|")
if IsArray(unhtmlgl) then
for i=0 to UBound(unhtmlgl)
unhtml=replace(unhtml,unhtmlgl(i),"***")
next
end if
end if
end function
%><!--#include file="MakeFunction.asp"--><!-- #include file='ShowHOT1.asp' --><!--#include file="ShowHOTS.asp"--><!--#include file="guanggao.asp"--><!--#include file="UBBCODEs.ASP"-->⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -