Asp常用函数(比较完整版)

<%
Dim Moonpotato
Set Moonpotato=New Moonpotato_Cls
Class Moonpotato_Cls
Public Badwords,Badwordr

'================================================
'过程名：Writefile
'作用：导出Excel
'================================================
Public Sub Excel()
Response.Buffer = True
Response.ContentType = "application/vnd.ms-excel"
Response.AddHeader "content-disposition", "inline; filename = "& Session("CompanyName")&Date()&".xls"
End Sub

'================================================
'过程名：Writefile
'作用：写入文件
'================================================
Public Sub Tclass(id,title,table,choose)
Set Rs=HK.ExeCute ("Select "& id &","& title &" from "& table &" "& choose &"")
Do while not Rs.eof
Response.write "<option value='"
Response.write Rs(""&id&"")
Response.write "'>"
Response.write Rs(""&title&"")
Response.write "</option>"
Rs.movenext
Loop
Rs.close
Set rs=Nothing
End Sub
'================================================
'过程名：Writefile
'作用：写入文件
'================================================
Public Sub Readfile(writefile,fileStr)
Dim Fso,F
Set Fso=Server.Createobject("Scripting.FileSystemObject")
Set F=fso.CreateTextFile(Server.MapPath(writefile),true)
F.WriteLine fileStr
F.close
Set F = Nothing
Set Fso = Nothing
End Sub
'================================================
'过程名：Readfile
'作用：读取文件
'================================================
Public Sub Readfilea(filename)
Dim Fso,F
Set Fso=Server.CreateObject("Scripting.FileSystemObject")
Set F=fso.OpenTextFile(Server.MapPath(filename))
strOut=F.ReadAll
F.close
Set F = Nothing
Set Fso = Nothing
End Sub
'================================================
'过程名：Readfolder
'作用：读取文件夹
'================================================
Public Sub Readfolder()
Set MyFileObject=Server.CreateObject("Scripting.FileSystemObject")
Set MyFolder=MyFileObject.GetFolder("\")
For Each thing in MyFolder.files
   Response.Write thing & "<br>"
Next
End Sub
'================================================
'过程名：RemoveCookies
'作用：移除本站Cookies
'================================================
Public Sub RemoveCookies()
Dim Cookie, Subkey
For Each Cookie in Request.Cookies
if Not(Request.Cookies(Cookie).HasKeys) then
   Response.Cookies(Cookie) = Empty
else
   For Each Subkey in Request.Cookies(Cookie)
    Response.Cookies(Cookie)(Subkey) = Empty
   Next
end if
Next
End Sub
'================================================
'函数名：IsValidStr
'作用：判断字符串中是否含有非法字符
'参数：str   ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidStr(ByVal str)
IsValidStr = False
On Error Resume Next
If IsNull(str) Then Exit Function
   If Trim(str) = Empty Then Exit Function
   Dim ForbidStr, i
   ForbidStr = "and|chr|:|=|%|&|$|#|@|+|-|*|/|\|<|>|;|,|^|" & Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
   ForbidStr = Split(ForbidStr, "|")
   For i = 0 To UBound(ForbidStr)
    If InStr(1,str, ForbidStr(i),1) > 0 Then
     IsValidStr = False
     Exit Function
    End If
   Next
IsValidStr = True
End Function
'================================================
'函数名：IsValidPassword
'作用：判断密码中是否含有非法字符
'参数：str   ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidPassword(ByVal str)
IsValidPassword = False
On Error Resume Next
If IsNull(str) Then Exit Function
   If Trim(str) = Empty Then Exit Function
   Dim ForbidStr, i
   ForbidStr = Chr(32) & "|" & Chr(34) & "|" & Chr(39) & "|" & Chr(9)
   ForbidStr = Split(ForbidStr, "|")
   For i = 0 To UBound(ForbidStr)
    If InStr(1, str, ForbidStr(i), 1) > 0 Then
     IsValidPassword = False
     Exit Function
    End If
   Next
IsValidPassword = True
End Function
'================================================
'函数名：IsValidChar
'作用：判断字符串中是否含有非法字符和中文
'参数：str   ----原字符串
'返回值：False,True -----布尔值
'================================================
Public Function IsValidChar(ByVal str)
IsValidChar = False
On Error Resume Next
If IsNull(str) Then Exit Function
   If Trim(str) = Empty Then Exit Function
   Dim ValidStr
   Dim i, l, s, c
   ValidStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ.-_:~\/0123456789"
   l = Len(str)
   s = UCase(str)
   For i = 1 To l
    c = Mid(s, i, 1)
    If InStr(ValidStr, c) = 0 Then
     IsValidChar = False
     Exit Function
    End If
   Next
IsValidChar = True
End Function
'================================================
'函数名：FormatDate
'作用：格式化日期
'参数：DateAndTime   ----原日期和时间
'        para   ----日期格式
'返回值：格式化后的日期
'================================================
Public Function FormatDate(DateAndTime, para)
On Error Resume Next
Dim y, m, d, h, mi, s, strDateTime
FormatDate = DateAndTime
If Not IsNumeric(para) Then Exit Function
   If Not IsDate(DateAndTime) Then Exit Function
   y = CStr(Year(DateAndTime))
   m = CStr(Month(DateAndTime))
   If Len(m) = 1 Then m = "0" & m
   d = CStr(Day(DateAndTime))
   If Len(d) = 1 Then d = "0" & d
   h = CStr(Hour(DateAndTime))
   If Len(h) = 1 Then h = "0" & h
   mi = CStr(Minute(DateAndTime))
   If Len(mi) = 1 Then mi = "0" & mi
   s = CStr(Second(DateAndTime))
   If Len(s) = 1 Then s = "0" & s
   Select Case para
    Case "1":strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
    Case "2":strDateTime = y & "-" & m & "-" & d
    Case "3":strDateTime = y & "/" & m & "/" & d
    Case "4":strDateTime = y & "年" & m & "月" & d & "日"
    Case "5":strDateTime = m & "-" & d
    Case "6":strDateTime = m & "/" & d
    Case "7":strDateTime = m & "月" & d & "日"
    Case "8":strDateTime = y & "年" & m & "月"
    Case "9":strDateTime = y & "-" & m
    Case "10":strDateTime = y & "/" & m
   Case Else
    strDateTime = DateAndTime
   End Select
FormatDate = strDateTime
End Function
'================================================
'函数名：CheckInfuse
'作用：防止SQL注入
'参数：str   ----原字符串
'        strLen ----提交字符串长度
'================================================
Public Function CheckInfuse(ByVal str, ByVal strLen)
Dim strUnsafe, arrUnsafe
Dim i
If Trim(str) = "" Then
   CheckInfuse = ""
   Exit Function
End If
str = Left(str, strLen)
On Error Resume Next
strUnsafe = "'|^|;|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
If Trim(str) <> "" Then
   If Len(str) > strLen Then
    Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n您提交的字符数超过了限制！');history.back(-1)</Script>"
    CheckInfuse = ""
    Response.End
   End If
   arrUnsafe = Split(strUnsafe, "|")
   For i = 0 To UBound(arrUnsafe)
    If InStr(1, str, arrUnsafe(i), 1) > 0 Then
     Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
     CheckInfuse = ""
     Response.End
    End If
   Next
End If
CheckInfuse = Trim(str)
Exit Function
If Err.Number <> 0 Then
   Err.Clear
   Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
   CheckInfuse = ""
   Response.End
End If
End Function

Public Sub PreventInfuse()
On Error Resume Next
Dim SQL_Nonlicet, arrNonlicet
Dim PostRefer, GetRefer, Sql_DATA
SQL_Nonlicet = "'|;|^|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
arrNonlicet = Split(SQL_Nonlicet, "|")
If Request.Form <> "" Then
   For Each PostRefer In Request.Form
    For Sql_DATA = 0 To UBound(arrNonlicet)
     If InStr(1, Request.Form(PostRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
      Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
      Response.End
     End If
    Next
   Next
End If
If Request.QueryString <> "" Then
   For Each GetRefer In Request.QueryString
    For Sql_DATA = 0 To UBound(arrNonlicet)
     If InStr(1, Request.QueryString(GetRefer), arrNonlicet(Sql_DATA), 1) > 0 Then
      Response.Write "<Script Language=JavaScript>alert('安全系统提示↓\n\n请不要在参数中包含非法字符！');history.back(-1)</Script>"
      Response.End
     End If
    Next
   Next
End If
End Sub
'================================================
'函数名：ChkQueryStr
'作用：过虑查询的非法字符
'参数：str   ----原字符串
'返回值：过滤后的字符
'================================================
Public Function ChkQueryStr(ByVal str)
On Error Resume Next
If IsNull(str) Then
   ChkQueryStr = ""
   Exit Function
End If
str = Replace(str, "!", "")
str = Replace(str, "]", "")
str = Replace(str, "[", "")
str = Replace(str, ")", "")
str = Replace(str, "(", "")
str = Replace(str, "|", "")
str = Replace(str, "+", "")
str = Replace(str, "=", "")
str = Replace(str, "'", "''")
str = Replace(str, "%", "")
str = Replace(str, "&", "")
str = Replace(str, "@", "")
str = Replace(str, "#", "")
str = Replace(str, "^", "")
str = Replace(str, "《", "")
str = Replace(str, "》", "")
str = Replace(str, " ", " ")
str = Replace(str, Chr(37), "")
str = Replace(str, Chr(0), "")
ChkQueryStr = str
End Function
'=================================================
'函数名：isInteger
'作用：判断数字是否整型
'参数：para ----参数
'=================================================
Public Function isInteger(ByVal para)
On Error Resume Next
Dim str
Dim l, i
If IsNull(para) Then
   isInteger = False
   Exit Function
End If
str = CStr(para)
If Trim(str) = "" Then
   isInteger = False
Exit Function
End If
l = Len(str)
For i = 1 To l
   If Mid(str, i, 1) > "9" Or Mid(str, i, 1) < "0" Then
    isInteger = False
    Exit Function
   End If
Next
isInteger = True
If Err.Number <> 0 Then Err.Clear
End Function
'=============================================================
'函数名：ChkBadWords
'函数作用：带脏话过滤
'=============================================================
Public Function ChkBadWords(ByVal str)
If IsNull(str) Then Exit Function
Dim i, Bwords, Bwordr
Bwords = Split(Badwords, "|")
Bwordr = Split(Badwordr, "|")
For i = 0 To UBound(Bwords)
   If i > UBound(Bwordr) Then
    str = Replace(str, Bwords(i), "*")
   Else
    str = Replace(str, Bwords(i), Bwordr(i))
   End If
Next
ChkBadWords = str
End Function
'=============================================================
'函数名：HTMLEncode
'函数作用：过滤HTML代码，带脏话过滤
'=============================================================
Public Function HTMLEncode(ByVal fString)
If Not IsNull(fString) Then
   fString = Replace(fString, ">", ">")
   fString = Replace(fString, "<", "<")
   fString = Replace(fString, Chr(32), " ")
   fString = Replace(fString, Chr(9), " ")
   fString = Replace(fString, Chr(34), """)
   fString = Replace(fString, Chr(39), "'")
   fString = Replace(fString, Chr(13), "")
   fString = Replace(fString, " ", " ")
   fString = Replace(fString, Chr(10), "<br /> ")
   fString = ChkBadWords(fString)
   HTMLEncode = fString
End If
End Function
'=============================================================
'函数名：HTMLEncodes
'函数作用：过滤HTML代码，不带脏话过滤
'=============================================================
Public Function HTMLEncodes(ByVal fString)
If Not IsNull(fString) Then
   fString = Replace(fString, "'", "'")
   fString = Replace(fString, ">", ">")
   fString = Replace(fString, "<", "<")
   fString = Replace(fString, Chr(32), " ")
   fString = Replace(fString, Chr(9), " ")
   fString = Replace(fString, Chr(34), """)
   fString = Replace(fString, Chr(39), "'")
   fString = Replace(fString, Chr(13), "")
   fString = Replace(fString, Chr(10), "<br /> ")
   fString = Replace(fString, " ", " ")
   HTMLEncodes = fString
End If
End Function
'=============================================================
'函数名：CheckPost
'函数作用：判断发言是否来自外部
'=============================================================
Public Function CheckPost()
On Error Resume Next
Dim server_v1, server_v2
CheckPost = False
server_v1 = CStr(Request.ServerVariables("HTTP_REFERER"))
server_v2 = CStr(Request.ServerVariables("SERVER_NAME"))
If Mid(server_v1, 8, Len(server_v2)) = server_v2 Then
   CheckPost = True
End If
End Function
'=============================================================
'函数名：CheckOuterUrl
'函数作用：判断来源URL是否来自外部
'=============================================================
Public Function CheckOuterUrl()
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
   CheckOuterUrl = False
Else
   CheckOuterUrl = True
End If
End Function
'================================================
'函数名：ChkKeyWord
'作用：过滤关键字
'参数：keyword ----关键字
'================================================
Public Function ChkKeyWord(ByVal keyword)
Dim FobWords, i
On Error Resume Next
FobWords = Array(91, 92, 304, 305, 430, 431, 437, 438, 12460, 12461, 12462, 12463, 12464, 12465, 12466, 12467, 12468, 12469, 12470, 12471, 12472, 12473, 12474, 12475, 12476, 12477, 12478, 12479, 12480, 12481, 12482, 12483, 12485, 12486, 12487, 12488, 12489, 12490, 12496, 12497, 12498, 12499, 12500, 12501, 12502, 12503, 12504, 12505, 12506, 12507, 12508, 12509, 12510, 12521, 12532, 12533, 65339, 65340)
For i = 1 To UBound(FobWords, 1)
   If InStr(keyword, ChrW(FobWords(i))) > 0 Then
    keyword = Replace(keyword, ChrW(FobWords(i)), "")
   End If
Next
keyword = Left(keyword, 100)
FobWords = Array("~", "!", "@", "#", "$", "%", "^", "&", "*", "(", ")", "_", "+", "=", "`", "[", "]", "{", "}", ";", ":", """", "'", ",", "<", ">", ".", "/", "\", "?", "--")
For i = 0 To UBound(FobWords, 1)
   If InStr(keyword, FobWords(i)) > 0 Then
    keyword = Replace(keyword, FobWords(i), "")
   End If
Next
ChkKeyWord = keyword
End Function
'================================================
'函数名：FilesDelete
'作用：FSO删除文件
'参数：filepath   ----文件路径
'返回值：False ---- True
'================================================
Public Function FileDelete(ByVal FilePath)
On Error Resume Next
FileDelete = False
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If FilePath = "" Then Exit Function
If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath)
If fso.FileExists(FilePath) Then
   fso.DeleteFile FilePath, True
   FileDelete = True
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：FolderDelete
'作用：FSO删除目录
'参数：folderpath   ----目录路径
'回值：False ---- True
'================================================
Public Function FolderDelete(ByVal FolderPath)
FolderDelete = False
On Error Resume Next
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If FolderPath = "" Then Exit Function
If InStr(FolderPath, ":") = 0 Then FolderPath = Server.MapPath(FolderPath)
If fso.FolderExists(FolderPath) Then
   fso.DeleteFolder FolderPath, True
   FolderDelete = True
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CopyToFile
'作用：复制文件
'参数：SoureFile   ----原文件路径
'        NewFile ----目标文件路径
'================================================
Public Function CopyToFile(ByVal SoureFile, ByVal NewFile)
On Error Resume Next
If SoureFile = "" Then Exit Function
If NewFile = "" Then Exit Function
If InStr(SoureFile, ":") = 0 Then SoureFile = Server.MapPath(SoureFile)
If InStr(NewFile, ":") = 0 Then NewFile = Server.MapPath(NewFile)
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FileExists(SoureFile) Then
   fso.CopyFile SoureFile, NewFile
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：CopyToFolder
'作用：复制文件夹
'参数：SoureFolder   ----原路径
'        NewFolder ----目标路径
'================================================
Public Function CopyToFolder(ByVal SoureFolder, ByVal NewFolder)
On Error Resume Next
If SoureFolder = "" Then Exit Function
If NewFolder = "" Then Exit Function
If InStr(SoureFolder, ":") = 0 Then SoureFolder = Server.MapPath(SoureFolder)
If InStr(NewFolder, ":") = 0 Then NewFolder = Server.MapPath(NewFolder)
Dim fso
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FolderExists(SoureFolder) Then
   fso.CopyFolder SoureFolder, NewFolder
End If
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function

'================================================
'函数名：CreatedTextFile
'作用：创建文本文件
'参数：filename ----文件名
'        body ----主要内容
'================================================
Public Function CreatedTextFile(ByVal fromPath, ByVal body)
On Error Resume Next
Dim fso,fff
If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
Set fso = Server.CreateObject(FSO_ScriptName)
Set fff = fso.OpenTextFile(fromPath, 2, True)
fff.Write body
fff.Close
Set fff = Nothing
Set fso = Nothing
If Err.Number <> 0 Then Err.Clear
End Function

Public Function CreatedTextFiles(ByVal FileName, ByVal body)
On Error Resume Next
If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName)
Dim oStream
Set oStream = CreateObject("ADODB.Stream")
oStream.Type = 2 '设置为可读可写
oStream.Mode = 3 '设置内容为文本
oStream.Charset = "GB2312"
oStream.Open
oStream.Position = oStream.Size
oStream.WriteText body
oStream.SaveToFile FileName, 2
oStream.Close
Set oStream = Nothing
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'函数名：Readfile
'作用：读取文件内容
'参数：fromPath   ----来源文件路径
'================================================
Public Function Readfileb(ByVal fromPath)
On Error Resume Next
Dim strTemp,fso,f
If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
Set fso = Server.CreateObject(FSO_ScriptName)
If fso.FileExists(fromPath) Then
Set f = fso.OpenTextFile(fromPath, 1, True)
strTemp = f.ReadAll
f.Close
Set f = Nothing
End If
Set fso = Nothing
Readfile = strTemp
If Err.Number <> 0 Then Err.Clear
End Function
'================================================
'过程名：ReturnError
'作用：显示错误信息
'================================================
Public Sub ReturnError(ErrMsg)
Response.Write "<html><head><title>错误提示信息!</title><meta http-equiv=Content-Type content=text/html; charset=gb2312>" & vbCrLf
Response.Write "<meta http-equiv=refresh content=5;url=" & Request.ServerVariables("HTTP_REFERER") & ">"
Response.Write "<link href=""css/main1.css"" rel=""stylesheet"" type=""text/css""></head><body>" & vbCrLf
Response.Write "<table width=271 height=140 border=0 align=center cellpadding=0 cellspacing=0 background=images/wrong.gif & vbCrLf
    Response.Write "<tr>" & vbCrLf
    Response.Write "<th height=""30"" colspan=2 align=""left""> </th>" & vbCrLf
    Response.Write "</tr>" & vbCrLf
    Response.Write "<tr><td align=center width=""76""> </td>" & vbCrLf
    Response.Write "<td width=""175"" height=""85"" style=line-height:20px;>" & vbCrLf
    Response.Write "<b style=color:#ff0000><span 秒钟后系统将自动返回</b><br>"
    Response.Write ErrMsg & "</td>" & vbCrLf
    Response.Write "</tr>" & vbCrLf
    Response.Write "<tr><td colspan=2 align=center height=25 href='" & Request.ServerVariables("HTTP_REFERER") & "'>返回上一页...</a></td>" & vbCrLf
    Response.Write "</tr>" & vbCrLf
    Response.Write "</table>"
Response.Write "</body></html>" & vbCrLf
Response.Write "<script>function countDown(secs){jump.innerText=secs;if(--secs>0)setTimeout(""countDown(""+secs+"")"",1000);}countDown(3);</script>"
End Sub
'================================================
'过程名：Succeed
'作用：显示成功信息
'================================================
Public Sub Succeed(SucMsg)
Response.Write "<html><head><title>成功提示信息!</title><meta http-equiv=Content-Type content=text/html; charset=gb2312>" & vbCrLf
Response.Write "<meta http-equiv=refresh content=5;url=" & Request.ServerVariables("HTTP_REFERER") & ">"
Response.Write "<link href=""css/main1.css"" rel=""stylesheet"" type=""text/css""></head><body>" & vbCrLf
Response.Write "<table width=271 height=140 border=0 align=center cellpadding=0 cellspacing=0 background=images/succ.gif & vbCrLf
    Response.Write "<tr>" & vbCrLf
    Response.Write "<th height=""30"" colspan=2 align=""left""> </th>" & vbCrLf
    Response.Write "</tr>" & vbCrLf
    Response.Write "<tr><td align=center width=""76""> </td>" & vbCrLf
    Response.Write "<td width=""175"" height=""85"" style=line-height:20px;>" & vbCrLf
    Response.Write "<b style=color:#ff0000><span 秒钟后系统将自动返回</b><br>"
    Response.Write SucMsg & "</td>" & vbCrLf
    Response.Write "</tr>" & vbCrLf
    Response.Write "<tr><td colspan=2 align=center height=25 href='" & Request.ServerVariables("HTTP_REFERER") & "'>返回上一页...</a></td>" & vbCrLf
    Response.Write "</tr>" & vbCrLf
    Response.Write "</table>"
Response.Write "</body></html>" & vbCrLf
Response.Write "<script>function countDown(secs){jump.innerText=secs;if(--secs>0)setTimeout(""countDown(""+secs+"")"",1000);}countDown(3);</script>"
End Sub
'================================================
' 函数名：RelativePath2RootPath
' 作用：转为根路径格式
' 参数：url ----原URL
' 返回值：转换后的URL
'================================================
Public Function RelativePath2RootPath(url)
Dim sTempUrl
sTempUrl = url
If Left(sTempUrl, 1) = "/" Then
RelativePath2RootPath = sTempUrl
Exit Function
End If

Dim sFilePath
sFilePath = Request.ServerVariables("SCRIPT_NAME")
sFilePath = Left(sFilePath, InstrRev(sFilePath, "/") - 1)
Do While Left(sTempUrl, 3) = "../"
sTempUrl = Mid(sTempUrl, 4)
sFilePath = Left(sFilePath, InstrRev(sFilePath, "/") - 1)
Loop
RelativePath2RootPath = sFilePath & "/" & sTempUrl
End Function
'================================================
' 函数名：RootPath2DomainPath
' 作用：根路径转为带域名全路径格式
' 参数：url ----原URL
' 返回值：转换后的URL
'================================================
Public Function RootPath2DomainPath(url)
Dim sHost, sPort
sHost = Split(LCase(Request.ServerVariables("SERVER_PROTOCOL")), "/")(0) & "://" & Request.ServerVariables("HTTP_HOST")
sPort = Request.ServerVariables("SERVER_PORT")
If sPort <> "80" Then
sHost = sHost & ":" & sPort
End If
RootPath2DomainPath = sHost & url
End Function
'================================================
' 函数名：ChkMapPath
' 作用：相对路径转换为绝对路径
' 参数：strPath ----原路径
' 返回值：绝对路径
'================================================
Public Function ChkMapPath(ByVal strPath)
On Error Resume Next
Dim fullPath
strPath = Replace(Replace(Trim(strPath), "//", "/"), "\\", "\")

If strPath = "" Then strPath = "."
If InStr(strPath,":\") = 0 Then
fullPath = Server.MapPath(strPath)
Else
strPath = Replace(strPath,"/","\")
fullPath = Trim(strPath)
If Right(fullPath, 1) = "\" Then
   fullPath = Left(fullPath, Len(fullPath) - 1)
End If
End If
ChkMapPath = fullPath
End Function
'================================================
' 函数名：CreatePath
' 作用：按月份自动创建文件夹
' 参数：fromPath ----原文件夹路径
'================================================
Public Function CreatePath(fromPath)
Dim objFSO, uploadpath
uploadpath = Year(Now) & "-" & Month(Now) '以年月创建上传文件夹，格式：2003－8
On Error Resume Next
Set objFSO = CreateObject(Newasp.FSO_ScriptName)
If objFSO.FolderExists(Server.MapPath(fromPath & uploadpath)) = False Then
objFSO.CreateFolder Server.MapPath(fromPath & uploadpath)
End If
If Err.Number = 0 Then
CreatePath = uploadpath & "/"
Else
CreatePath = ""
End If
Set objFSO = Nothing
End Function
'================================================
'过程名：SaveLogInfo
'作用：记录管理日志
'================================================
Public Sub SaveLogInfo(lname)
Dim RequestStr
Dim lsql,istoplog
istoplog = 0      '是否停止日志,1=停止,0=启用
If istoplog = 1 Then Exit Sub
On Error Resume Next
ConnectionLogDatabase
If InStr(Newasp.ScriptName, "_index") > 0 Or InStr(Newasp.ScriptName, "admin_log") > 0 Then Exit Sub
lname = Newasp.CheckStr(lname)
RequestStr = lcase(Request.ServerVariables("Query_String"))
If RequestStr <> "" Then
RequestStr=checkStr(RequestStr)
RequestStr=Left(RequestStr,250)
lsql = "insert into [NC_LogInfo] (UserName,UserIP,ScriptName,ActContent,LogAddTime,LogType) values ('"& lname &"','"& Newasp.GetUserip &"','"& Newasp.ScriptName &"','"& RequestStr &"','"& Now() &"',0)"
lconn.Execute(lsql)
End If
If Request.form <> "" Then
RequestStr = checkStr(request.form)
RequestStr = Left(RequestStr,250)
lsql = "insert into [NC_LogInfo] (UserName,UserIP,ScriptName,ActContent,LogAddTime,LogType) values ('"& lname &"','"& Newasp.GetUserip &"','"& Newasp.ScriptName &"','"& RequestStr &"','"& Now() &"',1)"
lconn.Execute(lsql)
End If
If IsObject(lconn) Then
lconn.Close
Set lconn = Nothing
End If
End Sub
'================================================
'函数名：RemoveHTML
'作用：替换HTML标签
'================================================
Public Function RemoveHTML(strText)
   Dim RegEx
   Set RegEx = New RegExp
   RegEx.Pattern = "<[^>]*>"
   RegEx.Global = True
   RemoveHTML = RegEx.Replace(strText,"")
End Function
'================================================
'过程名：PreventRefresh
'作用：防止刷新页面
'================================================
Public Sub PreventRefresh()
Dim RefreshTime,isRefresh
RefreshTime = 10   '防止刷新时间,单位（秒）
isRefresh = 1    '是否使用防刷新功能，0=否，1=是
If isRefresh = 1 Then
If (Not IsEmpty(Session("RefreshTime"))) And RefreshTime > 0 Then
   If DateDiff("s", Session("RefreshTime"), Now()) < RefreshTime Then
    Response.Write "<META http-equiv=Content-Type content=text/html; chaRset=gb2312><meta HTTP-EQUIV=REFRESH CONTENT="&RefreshTime&"><br>本页面起用了防刷新机制，请不要在"&RefreshTime&"秒内连续刷新本页面<BR>正在打开页面，请稍后……"
    Response.End
   Else
    Session("RefreshTime") = Now()
   End If
Else
   Session("RefreshTime") = Now()
End If
End If
End Sub
'================================================
'过程名：CheckAdmin
'判断管理员权限
'================================================
Public Function CheckAdmin(flag)
Dim Rs, SQL
Dim i, TempAdmin, Adminflag,AdminGrade
CheckAdmin = False
On Error Resume Next
SQL ="SELECT id,AdminGrade,Adminflag FROM [NC_Admin] WHERE username='"& Replace(Session("AdminName"), "'", "''") &"' And password='"& Replace(Session("AdminPass"), "'", "''") &"' And isLock=0 And CLng(Session("AdminID"))
Set Rs = Newasp.Execute(SQL)
If Rs.BOF And Rs.EOF Then
CheckAdmin = False
Set Rs = Nothing
Exit Function
Else
Adminflag = Rs("Adminflag")
AdminGrade = Rs("AdminGrade")
End If
Rs.Close:Set Rs = Nothing
If CInt(AdminGrade) = 999 Then
CheckAdmin = True
Exit Function
Else
If Trim(flag) = "" Then Exit Function
If Adminflag = "" Then
   CheckAdmin = False
   Exit Function
Else
   tempAdmin = Split(AdminFlag, ",")
   For i = 0 To UBound(tempAdmin)
    If LCase(tempAdmin(i)) = LCase(flag) Then
     CheckAdmin = True
     Exit For
    End If
   Next
End If
End If
End Function
'================================================
'过程名：Sendmail
'Jmail发信组件
'================================================
Public Sub Sendmail(SmtpName,EmailPwd,SendEmailName,SendName,StoryEmailName,Object,EmailContent)
Set msg=Server.CreateObject("Jmail.Message")
msg.silent=true
msg.Logging = true
msg.Charset = "gb2312"
msg.MailServerUserName = ""& SmtpName &""          '输入smtp服务器验证登陆名 progressivest@163.com
msg.MailServerPassword = ""& EmailPwd &""          '输入smtp服务器验证密码 111111
msg.From = ""& SendEmailName &""                   '发件人 progressivest@163.com
msg.FromName = ""& SendName &""                    '发件人姓名刘志锋
msg.AddRecipient ""& StoryEmailName &""            '收件人lzfwgf@tom.com
msg.Subject = ""& Object &""                       '主题测试JMmail
msg.Body = ""& EmailContent &""                    '正文
msg.Priority = 1                                   '设定邮件优先级1为紧急，3为正常，5为缓慢。
msg.Send (""& SmtpServer &"")                      '邮件服务器 smtp.163.com
set msg = nothing
Response.Write("发信成功")
End Sub
'================================================
'作用：输出错误警告脚本
'参数：str ----参数入口
'返回值：警告信息
'================================================
Public Sub OutAlertScript(str)
Response.Write "<script language=javascript>" & vbcrlf
Response.Write "alert('" & str & "');"
Response.Write "history.back()" & vbcrlf
Response.Write "</script>" & vbcrlf
Response.End
End Sub

Public Sub OutHintScript(str)
Response.Write "<script language=JavaScript>" & vbCrLf
Response.Write "alert('" & str & "');"
Response.Write "location.replace('" & Request.ServerVariables("HTTP_REFERER") & "')" & vbCrLf
Response.Write "</script>" & vbCrLf
Response.End
End Sub

Public Sub OutputScript(str,url)
Response.Write "<script language=JavaScript>" & vbCrLf
Response.Write "alert('" & str & "');"
Response.Write "location.replace('" & url & "')" & vbCrLf
Response.Write "</script>" & vbCrLf
Response.End
End Sub

Public Sub Script(Str,Url)
Response.write "<Script Language='JavaScript'>"
Response.write "alert('"& Str &"');"
Response.write "window.location.href='"& Url &"';"
Response.write "</Script>"
End Sub

Public Sub OutPut(Strings)
Response.Write "document.write('"
Response.Write Strings
Response.Write "');"
Response.Write vbNewline
End Sub
'================================================
'函数名：MakeFileName
'以服务器时间为基础的数字串
'================================================
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
'================================================
'函数名:Url
'判断是否从外部提交数据
'================================================
Public Function Url()
Dim ComeUrl,cUrl
ComeUrl=lcase(trim(request.ServerVariables("HTTP_REFERER")))
if ComeUrl="" then
Response.write "<br><p align=center><font color='red'>对不起，为了系统安全，"
Response.write "不允许直接输入地址访问本系统的后台管理页面。</font></p>"
Response.End()
Else
cUrl=trim("http://" & Request.ServerVariables("SERVER_NAME"))
if mid(ComeUrl,len(cUrl)+1,1)=":" then
cUrl=cUrl & ":" & Request.ServerVariables("SERVER_PORT")
End if
cUrl=lcase(cUrl & request.ServerVariables("SCRIPT_NAME"))
if lcase(left(ComeUrl,instrrev(ComeUrl,"/")))<>lcase(left(cUrl,instrrev(cUrl,"/"))) then
Response.write "<br><p align=center><font color='red'>对不起，为了系统安全，"
Response.write "不允许直接输入地址访问本系统的后台管理页面。</font></p>"
Response.End()
End if
End if
End Function
'================================================
'过程名：showpage
'作用：显示“上一页下一页”等信息
'参数：sfilename ----链接地址
'       totalnumber ----总数量
'       maxperpage ----每页数量
'       ShowTotal   ----是否显示总数量
'       ShowAllPages ---是否用下拉列表显示所有页面以供跳转。有某些页面不能使用，否则会出现JS错误。
'       strUnit     ----计数单位
'================================================
Public Sub showpage(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= "<table align='center'><tr><td>"
strTemp=strTemp & "共 <font color=blue><b>" & totalnumber & "</b></font> " & strUnit & "   "
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 size='1' " & strUrl & "page=" & "'+this.options[this.selectedIndex].value;"">"
     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></table>"
response.write strTemp
End sub
'================================================
'函数名：IsValidEmail
'作用：检查Email地址合法性
'参数：email ----要检查的Email地址
'返回值：True ----Email地址合法
'       False ----Email地址不合法
'================================================
Public 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 ----没有安装
'================================================
Public 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
'------------------检查某一目录是否存在-------------------
Function CheckDir(FolderPath)
dim fso
folderpath=Server.MapPath(".")&"\"&folderpath
Set fso = Server.CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(FolderPath) then
'存在
CheckDir = True
Else
'不存在
CheckDir = False
End if
Set fso = nothing
End Function
'-------------根据指定名称生成目录---------
Function MakeNewsDir(foldername)
dim fso,f
foldername=Server.MapPath(foldername)
Set fso = Server.CreateObject("Scripting.FileSystemObject")
    Set f = fso.CreateFolder(foldername)
Set fso = nothing
End Function
'-------------删除指定名称目录---------
Function DelDir(foldername)
On Error Resume next
dim fso,f
foldername=Server.MapPath(foldername)
Set fso = Server.CreateObject("Scripting.FileSystemObject")
    fso.DeleteFolder foldername
Set fso = nothing
if err=0 then
Response.write "文件删除成功"
Else
Response.write "没找到你要删除的文件"
End if
End Function
'-------------删除指定名称文件---------
Function Delfile(filename)
dim fso,f
filename=Server.MapPath(filename)
Set fso = Server.CreateObject("Scripting.FileSystemObject")
    fso.Deletefile filename
Set fso = nothing
End Function
'================================================
'过程名：WriteErrMsg
'作用：显示错误提示信息
'参数：无
'================================================
Public 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='style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
strErr=strErr & "<table cellpadding=2 cellspacing=1 border=0 width=400 align=center>" & vbcrlf
strErr=strErr & " <tr align='center' ><td height='22'><strong>错误信息</strong></td></tr>" & vbcrlf
strErr=strErr & " <tr ><td height='100' valign='top'><b>产生错误的可能原因：</b>" & errmsg &"</td></tr>" & vbcrlf
strErr=strErr & " <tr align='center' ><td><a href=';<< 返回上一页</a></td></tr>" & vbcrlf
strErr=strErr & "</table>" & vbcrlf
strErr=strErr & "</body></html>" & vbcrlf
response.write strErr
End sub
'================================================
'过程名：WriteSuccessMsg
'作用：显示成功提示信息
'参数：无
'================================================
Public 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='style.css' rel='stylesheet' type='text/css'></head><body><br><br>" & vbcrlf
strSuccess=strSuccess & "<table cellpadding=2 cellspacing=1 border=0 width=400 align=center>" & vbcrlf
strSuccess=strSuccess & " <tr align='center' ><td height='22'><strong>恭喜你！</strong></td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr ><td height='100' valign='top'><br>" & SuccessMsg &"</td></tr>" & vbcrlf
strSuccess=strSuccess & " <tr align='center' ><td> </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="" then
ReplaceBadChar=""
else
ReplaceBadChar=replace(replace(replace(replace(replace(replace(replace(strChar,"'",""),"*",""),"?",""),"(",""),")",""),"<",""),".","")
end if
End function
'================================================
'函数名：TrueIP
'作用：取得真实Ip地址
'================================================
Public Function TrueIP()
TIp=Request.ServerVariables("HTTP_X_FORWARDED_FOR")
BIp=Request.ServerVariables("REMOTE_ADDR")
if TIp="" then
TrueIP=BIp
Else
TrueIP=TIp
End if
End Function
End Class
%>