一些常用的ASP自定义函数全集

叁歲伎倆 2024-02-17 22:38 28阅读 0赞

<%
    
    '========================================================
    '函数导航
    '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
    
    %>