<%
'*********************************************************************
'函数导航
'FormatDate(DT,tp) ------------------------------------------日期格式化
'IsInteger(para)   ---------------------------检测传递的参数是否为数字型
'ChkrequestDate(Para) -----------------------检测传递的参数是否为日期型
'ChkPost() ------------------------------------不允许外部提交数据的选择
'IsValidEmail(email)------------------------------------------Email检测
'MakedownName()--------------------------------构造上传图片文件名随机数
'getIP() ----------------------------------------------------获取IP地址
'LeftTrue(str,n)---------------------------------------字符个数统一显示
'CheckSql()-为了系统的安全，直接在有数据库连接的地方都加上SQL注入的免疫
'Runtime()---------------------------------------------程序执行时间检测
'--------------------FSO文件|文件夹操作--------------------------------
'Checkfolder(folderpath)-------------------------------------创建文件夹
'Deletefolder(folderpath) -----------------------------------删除文件夹
'Filehaveno(FileName) ---------------------------------判断文件是否存在
'readfilerecord(Filename) -----------将指定的文件内容读出|只能是txt文本
'WriteString(String,FileName)------------把指定的字符串写到指定新文件中
'--------------------进制转化|加密|------------------------------------
'Encrypt(theNumber)| Decrypt(theNumber)   一套加解密ID的函数,最多8位
'UTF2GB(UTFStr) -------------------------将UTF8编码文字转换为GB编码文字
'toUTF8(szInput)-------------------------将GB编码文字转换为UTF8编码文字
'c10to2(x)-----------------------------------十进制代码转换为二进制代码
'c16to2(x)---------------------------------十六进制代码转换为二进制代码
'c2to16(x)---------------------------------二进制代码转换为十六进制代码
'c2to10(x)-----------------------------------二进制代码转换为十进制代码  
'**********************************************************************
%>
<%
StartTime=timer()
'日期格式化
Function FormatDate(DT,tp)
dim Y,M,D
Y=Year(DT)
M=month(DT)
D=Day(DT)
if M<10 then M="0"&M
if D<10 then D="0"&D
select case tp
case 1 FormatDate=Y&"年"&M&"月"&D&"日"
case 2 FormatDate=Y&"/"&M&"/"&D
case 3 FormatDate=M&"/"&D
     case 4 FormatDate=Y&"\"&M&"\"&D
case 5 FormatDate=Y&"-"&M&"-"&D
end select
End Function
'--------------------------------
' ---判断数据是否整型 Being-----------------------------
Function IsInteger(para)
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
'--------------------------------
'检测传递的参数是否为日期型
Function ChkrequestDate(Para)
ChkrequestDate=False
If Not (IsNull(Para) Or Trim(Para)="" Or Not IsDate(Para)) Then
    ChkrequestDate=True
End If
End Function
'--------------------------------
''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
'--------------------------------
'不允许外部提交数据的选择
Function ChkPost()
     dim HTTP_REFERER,SERVER_NAME
dim server_v1,server_v2
chkpost=false
     SERVER_NAME=CheckStr(Request.ServerVariables("SERVER_NAME"))
HTTP_REFERER=CheckStr(Request.ServerVariables("HTTP_REFERER"))
server_v1=Cstr(HTTP_REFERER)
server_v2=Cstr(SERVER_NAME)
if mid(server_v1,8,len(server_v2))<>server_v2 then
   chkpost=false
else
   chkpost=true
end if
End Function
'--------------------------------
'构造上传图片文件名随机数
function MakedownName()
dim fname
randomize
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,"下午","")
fname = int(fname) + int(((9-1+1)*Rnd + 1)*100000)   '6位
MakedownName=fname
end function
'--------------------------------
'获取IP地址
Function getIP()
     Dim strIPAddr
     If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" OR InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
         strIPAddr = Request.ServerVariables("REMOTE_ADDR")
     ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
         strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
     ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
         strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
     Else
         strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
     End If
     getIP = Trim(Mid(strIPAddr, 1, 30))
End Function
'--------------------------------
'防止SQL注入,为了系统的安全，直接在有数据库连接的地方都加上SQL注入的免疫
Function CheckSql()
     Dim sql_injdata  
     SQL_injdata = "'|and|exec|insert|select|delete|update|count|*|%|chr|mid|master|truncate|char|declare"
     SQL_inj = split(SQL_Injdata,"|")
     If Request.QueryString<>"" Then
         For Each SQL_Get In Request.QueryString
             For SQL_Data=0 To Ubound(SQL_inj)
                 if instr(Request.QueryString(SQL_Get),Sql_Inj(Sql_DATA))>0 Then
Response.Write "<Script Language='javascript'>{alert('请不要在参数中包含非法字符！');history.back(-1)}</Script>"
                     Response.end
                 end if
             next
         Next
     End If
     If Request.Form<>"" Then
         For Each Sql_Post In Request.Form
             For SQL_Data=0 To Ubound(SQL_inj)
                 if instr(Request.Form(Sql_Post),Sql_Inj(Sql_DATA))>0 Then
                     Response.Write "<Script Language='javascript'>{alert('请不要在参数中包含非法字符！');history.back(-1)}     </Script>"
                     Response.end
                 end if
             next
         next
     end if
End Function
'--------------------------------
'程序执行时间检测
Function Runtime()
EndTime=Timer()
If EndTime<StartTime Then
     EndTime=EndTime+24*3600
End if
RunTime=(EndTime-StartTime)*1000   '单位毫秒
End Function
'--------------------------------
'判断文件夹是否存在
Function Checkfolder(folderpath)
   Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
     If objFSO.FolderExists(Server.MapPath(""&folderpath&"")) Then
   Else
    objFSO.CreateFolder(Server.MapPath(""&folderpath&""))'不存在就建一个目录
   End If
   Set objFSO = Nothing
End Function
'--------------------------------
'删除文件夹
Function Deletefolder(folderpath)
   Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
       If objFSO.FolderExists(Server.MapPath(""&folderpath&"")) Then
    objFSO.deletefolder(server.MapPath(folderpath))
    end if
   Set objFSO = Nothing
End Function
'--------------------------------
'一套加解密字符串的函数,基本正确   ,最多8位
Function Encrypt(theNumber)
On Error Resume Next
Dim n, szEnc, t, HiN, LoN, i
n = CDbl((theNumber + 1570) ^ 2 - 7 * (theNumber + 1570) - 450)
If n < 0 Then szEnc = "R" Else szEnc = "J"
n = CStr(abs(n))
For i = 1 To Len(n) step 2
t = Mid(n, i, 2)
If Len(t) = 1 Then
szEnc = szEnc & t
Exit For
End If
HiN = (CInt(t) And 240) / 16
LoN = CInt(t) And 15
szEnc = szEnc & Chr(Asc("M") + HiN) & Chr(Asc("C") + LoN)
Next
Encrypt = szEnc
End Function

Function Decrypt(theNumber)
On Error Resume Next
Dim e, n, sign, t, HiN, LoN, NewN, i
e = theNumber
If Left(e, 1) = "R" Then sign = -1 Else sign = 1
e = Mid(e, 2)
NewN = ""
For i = 1 To Len(e) step 2
t = Mid(e, i, 2)
If Asc(t) >= Asc("0") And Asc(t) <= Asc("9") Then
NewN = NewN & t
Exit For
End If
HiN = Mid(t, 1, 1)
LoN = Mid(t, 2, 1)
HiN = (Asc(HiN) - Asc("M")) * 16
LoN = Asc(LoN) - Asc("C")
t = CStr(HiN Or LoN)
If Len(t) = 1 Then t = "0" & t
NewN = NewN & t
Next
e = CDbl(NewN) * sign
Decrypt = CLng((7 + sqr(49 - 4 * (-450 - e))) / 2 - 1570)
End Function
'--------------------------------
'函数功能:将指定的文件内容读出
'相关参数:FileName
'返回值:   文件全部内容
Function readfilerecord(Filename)
if instr(filename,".")=0 then exit function
set ffso=server.createobject("scripting.filesystemobject")
if ffso.FileExists(server.mappath(filename))=false then exit function
set re_ffso=ffso.OpenTextFile(server.mappath(filename),1,0,0)
readfilerecord=re_ffso.readall
re_ffso.close
set ffso=nothing
end function
'---------------------------------
'函数功能:判断文件是否存在
'相关参数:FileName
'返回值: 如果存在返回True,否则返回False  
Function Filehaveno(FileName)
set ffso=server.createobject("scripting.filesystemobject")
Filehaveno=ffso.FileExists(server.mappath(filename))
set ffso=nothing
End Function  
'----------------------------------
'函数功能:把指定的字符串写到指定新文件中
'相关参数:String(字符串),FileName(文件名)
'返回值:无  
Function WriteString(String,FileName)
if string="" then exit function
if filename="" then exit function
if instr(filename,".")=0 then exit function
set ffso=server.createobject("scripting.filesystemobject")
set wfso=ffso.CreateTextFile(server.mappath(filename))
wfso.Writeline(string)
wfso.close
set ffso=nothing
End Function
'---------------------------------------
'字符个数统一显示
'left函数,以英文说明为标准
Function LeftTrue(str,n)
If len(str)<=n/2 Then
LeftTrue=str
Else
Dim TStr
Dim l,t,c
Dim i
l=len(str)
t=l
TStr=""
t=0
for i=1 to l
c=asc(mid(str,i,1))
If c<0 then c=c+65536
If c>255 then
t=t+2
Else
t=t+1
End If
'If t>n Then exit for        '如果要显示字符
If t>n Then exit for        '如果要显示汉字
TStr=TStr&(mid(str,i,1))
next
LeftTrue = TStr
End If
End Function
'------------------------------------------
'UTF转GB---将UTF8编码文字转换为GB编码文字
function UTF2GB(UTFStr)

for Dig=1 to len(UTFStr)
   '如果UTF8编码文字以%开头则进行转换
   if mid(UTFStr,Dig,1)="%" then
      'UTF8编码文字大于8则转换为汉字
     if len(UTFStr) >= Dig+8 then
        GBStr=GBStr & ConvChinese(mid(UTFStr,Dig,9))
        Dig=Dig+8
     else
       GBStr=GBStr & mid(UTFStr,Dig,1)
     end if
   else
      GBStr=GBStr & mid(UTFStr,Dig,1)
   end if
next
UTF2GB=GBStr
end function

'UTF8编码文字将转换为汉字
function ConvChinese(x)
    A=split(mid(x,2),"%")
    i=0
    j=0
   for i=0 to ubound(A)
      A(i)=c16to2(A(i))
   next
   for i=0 to ubound(A)-1
     DigS=instr(A(i),"0")
     Unicode=""
     for j=1 to DigS-1
       if j=1 then
         A(i)=right(A(i),len(A(i))-DigS)
         Unicode=Unicode & A(i)
       else
          i=i+1
          A(i)=right(A(i),len(A(i))-2)
          Unicode=Unicode & A(i)
       end if
     next

     if len(c2to16(Unicode))=4 then
        ConvChinese=ConvChinese & chrw(int("&H" & c2to16(Unicode)))
     else
        ConvChinese=ConvChinese & chr(int("&H" & c2to16(Unicode)))
     end if
   next
end function

'二进制代码转换为十六进制代码
function c2to16(x)
    i=1
    for i=1 to len(x) step 4
       c2to16=c2to16 & hex(c2to10(mid(x,i,4)))
    next
end function

'二进制代码转换为十进制代码
function c2to10(x)
    c2to10=0
    if x="0" then exit function
      i=0
    for i= 0 to len(x) -1
       if mid(x,len(x)-i,1)="1" then c2to10=c2to10+2^(i)
    next
end function

'十六进制代码转换为二进制代码
function c16to2(x)
     i=0
     for i=1 to len(trim(x))
       tempstr= c10to2(cint(int("&h" & mid(x,i,1))))
       do while len(tempstr)<4
          tempstr="0" & tempstr
       loop
       c16to2=c16to2 & tempstr
    next
end function

'十进制代码转换为二进制代码
function c10to2(x)
    mysign=sgn(x)
    x=abs(x)
    DigS=1
    do
       if x<2^DigS then
         exit do
       else
         DigS=DigS+1
       end if
    loop
    tempnum=x

    i=0
    for i=DigS to 1 step-1
       if tempnum>=2^(i-1) then
          tempnum=tempnum-2^(i-1)
          c10to2=c10to2 & "1"
       else
          c10to2=c10to2 & "0"
       end if
    next
    if mysign=-1 then c10to2="-" & c10to2
end function
'-------------------------------
'GB转UTF8--将GB编码文字转换为UTF8编码文字
Function toUTF8(szInput)
     Dim wch, uch, szRet
     Dim x
     Dim nAsc, nAsc2, nAsc3
     '如果输入参数为空，则退出函数
     If szInput = "" Then
         toUTF8 = szInput
         Exit Function
     End If
     '开始转换
      For x = 1 To Len(szInput)
         '利用mid函数分拆GB编码文字
         wch = Mid(szInput, x, 1)
         '利用ascW函数返回每一个GB编码文字的Unicode字符代码
         '注：asc函数返回的是ANSI 字符代码，注意区别
         nAsc = AscW(wch)
         If nAsc < 0 Then nAsc = nAsc + 65536
    
         If (nAsc And &HFF80) = 0 Then
             szRet = szRet & wch
         Else
             If (nAsc And &HF000) = 0 Then
                 uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                 szRet = szRet & uch
             Else
                'GB编码文字的Unicode字符代码在0800 - FFFF之间采用三字节模版
                 uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                             Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                             Hex(nAsc And &H3F Or &H80)
                 szRet = szRet & uch
             End If
         End If
     Next
        
     toUTF8 = szRet
End Function

%>