主頁(yè) > 知識(shí)庫(kù) > ASP常用函數(shù)收藏亂七八糟未整理版

ASP常用函數(shù)收藏亂七八糟未整理版

%
'*******************************************************************
'取得IP地址
'*******************************************************************

Function Userip()
    Dim GetClientIP
    '如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
    GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
    If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
        '如果客戶端沒(méi)用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
        GetClientIP = Request.ServerVariables("REMOTE_ADDR")
    End If
    Userip = GetClientIP
End Function

'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************

Function cip(sip)
    tip = CStr(sip)
    sip1 = Left(tip, CInt(InStr(tip, ".") -1))
    tip = Mid(tip, CInt(InStr(tip, ".") + 1))
    sip2 = Left(tip, CInt(InStr(tip, ".") -1))
    tip = Mid(tip, CInt(InStr(tip, ".") + 1))
    sip3 = Left(tip, CInt(InStr(tip, ".") -1))
    sip4 = Mid(tip, CInt(InStr(tip, ".") + 1))
    cip = CInt(sip1) * 256 * 256 * 256 + CInt(sip2) * 256 * 256 + CInt(sip3) * 256 + CInt(sip4)
End Function

'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************

Sub alert(message)
    message = Replace(message, "'", "\'")
    Response.Write ("script>alert('"  message  "')/script>")
End Sub

'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************

Sub GoBack()
    Response.Write ("script>history.go(-1)/script>")
End Sub

'*******************************************************************
' 重定向另外的連接
'*******************************************************************

Sub Go(url)
    Response.Write ("script>location.href('"  url  "')/script>")
End Sub

'*******************************************************************
' 我比較喜歡將以上三個(gè)結(jié)合起來(lái)使用
'*******************************************************************

Function Alert(message, gourl)
    message = Replace(message, "'", "'")
    If gourl = "-1" Then
        Response.Write ("script language=javascript>alert('"  message  "');history.go(-1)/script>")
    Else
        Response.Write ("script language=javascript>alert('"  message  "');location='"  gourl "'/script>")
    End If
    Response.End()
End Function

'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************

Sub GoPage(url, s)
    s = s * 1000
    Response.Write "SCRIPT LANGUAGE=JavaScript>"
    Response.Write "window.setTimeout("Chr(34)"window.navigate('"url"')"Chr(34)","s")"
    Response.Write "/script>"
End Sub

'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************

Function isInteger(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

'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************

Function GetExtend(filename)
    Dim tmp
    If filename>"" Then
        tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
        tmp = LCase(tmp)
        If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
            getextend = "txt"
        Else
            getextend = tmp
        End If
    Else
        getextend = ""
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function CheckIn(Str)
    If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
        CheckIn = True
    Else
        CheckIn = False
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function HTMLEncode(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, Chr(10)  Chr(10), "/P>P> ")
        fString = Replace(fString, Chr(10), "BR> ")

        HTMLEncode = fString
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function HTMLcode(fString)
    If Not IsNull(fString) Then
        fString = Replace(fString, Chr(13), "")
        fString = Replace(fString, Chr(10)  Chr(10), "/P>P>")
        fString = Replace(fString, Chr(34), "")
        fString = Replace(fString, Chr(10), "BR>")
        HTMLcode = fString
    End If
End Function

%>

%
1.檢查是否有效郵件地址

Function CheckEmail(strEmail)
    Dim re
    Set re = New RegExp
    re.Pattern = "^[w-.]{1,}@([da-zA-Z-]{1,}.){1,}[da-zA-Z-]{2,3}$"
    re.IgnoreCase = True
    CheckEmail = re.Test(strEmail)
End Function

2.測(cè)試變量是否為空值，空值的含義包括：變量不存在 / 為空，對(duì)象為Nothing，0，空數(shù)組，字符串為空

Function IsBlank(ByRef Var)
    IsBlank = False
    Select Case True
        Case IsObject(Var)
            If Var Is Nothing Then IsBlank = True
        Case IsEmpty(Var), IsNull(Var)
            IsBlank = True
        Case IsArray(Var)
            If UBound(Var) = 0 Then IsBlank = True
        Case IsNumeric(Var)
            If (Var = 0) Then IsBlank = True
        Case Else
            If Trim(Var) = "" Then IsBlank = True
    End Select
End Function

3.得到瀏覽器目前的URL

Function GetCurURL()
    If Request.ServerVariables("HTTPS") = "on" Then
        GetCurrentURL = "https://"
    Else
        GetCurrentURL = "http://"
    End If
    GetCurURL = GetCurURL  Request.ServerVariables("SERVER_NAME")
    If (Request.ServerVariables("SERVER_PORT") > 80) Then GetCurURL = GetCurURL  ":"  Request.ServerVariables("SERVER_PORT")
    GetCurURL = GetCurURL  Request.ServerVariables("URL")
    If (Request.QueryString > "") Then GetCurURL = GetCurURL  "?"  Request.QueryString
End Function

4.MD5加密函數(shù)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32

Private m_lOnBits(30)
Private m_l2Power(30)

m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)

m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)

Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits  0 or iShiftBits > 31 Then
        Err.Raise 6
    End If

    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
End Function

Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits  0 or iShiftBits > 31 Then
        Err.Raise 6
    End If

    RShift = (lValue And H7FFFFFFE) m_l2Power(iShiftBits)

    If (lValue And H80000000) Then
        RShift = (RShift or (H40000000 m_l2Power(iShiftBits - 1)))
    End If
End Function

Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) or RShift(lValue, (32 - iShiftBits))
End Function

Private Function AddUnsigned(lX, lY)
    Dim lX4
    Dim lY4
    Dim lX8
    Dim lY8
    Dim lResult

    lX8 = lX And H80000000
    lY8 = lY And H80000000
    lX4 = lX And H40000000
    lY4 = lY And H40000000

    lResult = (lX And H3FFFFFFF) + (lY And H3FFFFFFF)

    If lX4 And lY4 Then
        lResult = lResult Xor H80000000 Xor lX8 Xor lY8
    ElseIf lX4 or lY4 Then
        If lResult And H40000000 Then
            lResult = lResult Xor HC0000000 Xor lX8 Xor lY8
        Else
            lResult = lResult Xor H40000000 Xor lX8 Xor lY8
        End If
    Else
        lResult = lResult Xor lX8 Xor lY8
    End If

    AddUnsigned = lResult
End Function

Private Function F(x, y, z)
    F = (x And y) or ((Not x) And z)
End Function

Private Function G(x, y, z)
    G = (x And z) or (y And (Not z))
End Function

Private Function H(x, y, z)
    H = (x Xor y Xor z)
End Function

Private Function I(x, y, z)
    I = (y Xor (x or (Not z)))
End Function

Private Sub FF(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(F(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub GG(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(G(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub HH(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(H(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Sub II(a, b, c, d, x, s, ac)
    a = AddUnsigned(a, AddUnsigned(AddUnsigned(I(b, c, d), x), ac))
    a = RotateLeft(a, s)
    a = AddUnsigned(a, b)
End Sub

Private Function ConvertToWordArray(sMessage)
    Dim lMessageLength
    Dim lNumberOfWords
    Dim lWordArray()
    Dim lBytePosition
    Dim lByteCount
    Dim lWordCount

    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448

    lMessageLength = Len(sMessage)

    lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) BITS_TO_A_BYTE)) (MODULUS_BITS BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)

    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
        lWordCount = lByteCount BYTES_TO_A_WORD
        lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
        lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
        lByteCount = lByteCount + 1
    Loop

    lWordCount = lByteCount BYTES_TO_A_WORD
    lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE

    lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(H80, lBytePosition)

    lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)

    ConvertToWordArray = lWordArray
End Function

Private Function WordToHex(lValue)
    Dim lByte
    Dim lCount

    For lCount = 0 To 3
        lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
        WordToHex = WordToHex  Right("0"  Hex(lByte), 2)
    Next
End Function

Public Function MD5(sMessage)
    Dim x
    Dim k
    Dim AA
    Dim BB
    Dim CC
    Dim DD
    Dim a
    Dim b
    Dim c
    Dim d

    Const S11 = 7
    Const S12 = 12
    Const S13 = 17
    Const S14 = 22
    Const S21 = 5
    Const S22 = 9
    Const S23 = 14
    Const S24 = 20
    Const S31 = 4
    Const S32 = 11
    Const S33 = 16
    Const S34 = 23
    Const S41 = 6
    Const S42 = 10
    Const S43 = 15
    Const S44 = 21

    x = ConvertToWordArray(sMessage)

    a = H67452301
    b = HEFCDAB89
    c = H98BADCFE
    d = H10325476

    For k = 0 To UBound(x) Step 16
        AA = a
        BB = b
        CC = c
        DD = d

        FF a, b, c, d, x(k + 0), S11, HD76AA478
        FF d, a, b, c, x(k + 1), S12, HE8C7B756
        FF c, d, a, b, x(k + 2), S13, H242070DB
        FF b, c, d, a, x(k + 3), S14, HC1BDCEEE
        FF a, b, c, d, x(k + 4), S11, HF57C0FAF
        FF d, a, b, c, x(k + 5), S12, H4787C62A
        FF c, d, a, b, x(k + 6), S13, HA8304613
        FF b, c, d, a, x(k + 7), S14, HFD469501
        FF a, b, c, d, x(k + 8), S11, H698098D8
        FF d, a, b, c, x(k + 9), S12, H8B44F7AF
        FF c, d, a, b, x(k + 10), S13, HFFFF5BB1
        FF b, c, d, a, x(k + 11), S14, H895CD7BE
        FF a, b, c, d, x(k + 12), S11, H6B901122
        FF d, a, b, c, x(k + 13), S12, HFD987193
        FF c, d, a, b, x(k + 14), S13, HA679438E
        FF b, c, d, a, x(k + 15), S14, H49B40821

        GG a, b, c, d, x(k + 1), S21, HF61E2562
        GG d, a, b, c, x(k + 6), S22, HC040B340
        GG c, d, a, b, x(k + 11), S23, H265E5A51
        GG b, c, d, a, x(k + 0), S24, HE9B6C7AA
        GG a, b, c, d, x(k + 5), S21, HD62F105D
        GG d, a, b, c, x(k + 10), S22, H2441453
        GG c, d, a, b, x(k + 15), S23, HD8A1E681
        GG b, c, d, a, x(k + 4), S24, HE7D3FBC8
        GG a, b, c, d, x(k + 9), S21, H21E1CDE6
        GG d, a, b, c, x(k + 14), S22, HC33707D6
        GG c, d, a, b, x(k + 3), S23, HF4D50D87
        GG b, c, d, a, x(k + 8), S24, H455A14ED
        GG a, b, c, d, x(k + 13), S21, HA9E3E905
        GG d, a, b, c, x(k + 2), S22, HFCEFA3F8
        GG c, d, a, b, x(k + 7), S23, H676F02D9
        GG b, c, d, a, x(k + 12), S24, H8D2A4C8A

        HH a, b, c, d, x(k + 5), S31, HFFFA3942
        HH d, a, b, c, x(k + 8), S32, H8771F681
        HH c, d, a, b, x(k + 11), S33, H6D9D6122
        HH b, c, d, a, x(k + 14), S34, HFDE5380C
        HH a, b, c, d, x(k + 1), S31, HA4BEEA44
        HH d, a, b, c, x(k + 4), S32, H4BDECFA9
        HH c, d, a, b, x(k + 7), S33, HF6BB4B60
        HH b, c, d, a, x(k + 10), S34, HBEBFBC70
        HH a, b, c, d, x(k + 13), S31, H289B7EC6
        HH d, a, b, c, x(k + 0), S32, HEAA127FA
        HH c, d, a, b, x(k + 3), S33, HD4EF3085
        HH b, c, d, a, x(k + 6), S34, H4881D05
        HH a, b, c, d, x(k + 9), S31, HD9D4D039
        HH d, a, b, c, x(k + 12), S32, HE6DB99E5
        HH c, d, a, b, x(k + 15), S33, H1FA27CF8
        HH b, c, d, a, x(k + 2), S34, HC4AC5665

        II a, b, c, d, x(k + 0), S41, HF4292244
        II d, a, b, c, x(k + 7), S42, H432AFF97
        II c, d, a, b, x(k + 14), S43, HAB9423A7
        II b, c, d, a, x(k + 5), S44, HFC93A039
        II a, b, c, d, x(k + 12), S41, H655B59C3
        II d, a, b, c, x(k + 3), S42, H8F0CCC92
        II c, d, a, b, x(k + 10), S43, HFFEFF47D
        II b, c, d, a, x(k + 1), S44, H85845DD1
        II a, b, c, d, x(k + 8), S41, H6FA87E4F
        II d, a, b, c, x(k + 15), S42, HFE2CE6E0
        II c, d, a, b, x(k + 6), S43, HA3014314
        II b, c, d, a, x(k + 13), S44, H4E0811A1
        II a, b, c, d, x(k + 4), S41, HF7537E82
        II d, a, b, c, x(k + 11), S42, HBD3AF235
        II c, d, a, b, x(k + 2), S43, H2AD7D2BB
        II b, c, d, a, x(k + 9), S44, HEB86D391

        a = AddUnsigned(a, AA)
        b = AddUnsigned(b, BB)
        c = AddUnsigned(c, CC)
        d = AddUnsigned(d, DD)
    Next

    MD5 = LCase(WordToHex(a)  WordToHex(b)  WordToHex(c)  WordToHex(d))
End Function

5.SHA256 加密，256位的加密哦！安全性更高！
Private m_lOnBits(30)
Private m_l2Power(30)
Private K(63)

Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32

m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)

m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)

K(0) = H428A2F98
K(1) = H71374491
K(2) = HB5C0FBCF
K(3) = HE9B5DBA5
K(4) = H3956C25B
K(5) = H59F111F1
K(6) = H923F82A4
K(7) = HAB1C5ED5
K(8) = HD807AA98
K(9) = H12835B01
K(10) = H243185BE
K(11) = H550C7DC3
K(12) = H72BE5D74
K(13) = H80DEB1FE
K(14) = H9BDC06A7
K(15) = HC19BF174
K(16) = HE49B69C1
K(17) = HEFBE4786
K(18) = HFC19DC6
K(19) = H240CA1CC
K(20) = H2DE92C6F
K(21) = H4A7484AA
K(22) = H5CB0A9DC
K(23) = H76F988DA
K(24) = H983E5152
K(25) = HA831C66D
K(26) = HB00327C8
K(27) = HBF597FC7
K(28) = HC6E00BF3
K(29) = HD5A79147
K(30) = H6CA6351
K(31) = H14292967
K(32) = H27B70A85
K(33) = H2E1B2138
K(34) = H4D2C6DFC
K(35) = H53380D13
K(36) = H650A7354
K(37) = H766A0ABB
K(38) = H81C2C92E
K(39) = H92722C85
K(40) = HA2BFE8A1
K(41) = HA81A664B
K(42) = HC24B8B70
K(43) = HC76C51A3
K(44) = HD192E819
K(45) = HD6990624
K(46) = HF40E3585
K(47) = H106AA070
K(48) = H19A4C116
K(49) = H1E376C08
K(50) = H2748774C
K(51) = H34B0BCB5
K(52) = H391C0CB3
K(53) = H4ED8AA4A
K(54) = H5B9CCA4F
K(55) = H682E6FF3
K(56) = H748F82EE
K(57) = H78A5636F
K(58) = H84C87814
K(59) = H8CC70208
K(60) = H90BEFFFA
K(61) = HA4506CEB
K(62) = HBEF9A3F7
K(63) = HC67178F2

Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits  0 or iShiftBits > 31 Then
        Err.Raise 6
    End If

    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
End Function

Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits  0 or iShiftBits > 31 Then
        Err.Raise 6
    End If

    RShift = (lValue And H7FFFFFFE) m_l2Power(iShiftBits)

    If (lValue And H80000000) Then
        RShift = (RShift or (H40000000 m_l2Power(iShiftBits - 1)))
    End If
End Function

Private Function AddUnsigned(lX, lY)
    Dim lX4
    Dim lY4
    Dim lX8
    Dim lY8
    Dim lResult

    lX8 = lX And H80000000
    lY8 = lY And H80000000
    lX4 = lX And H40000000
    lY4 = lY And H40000000

    lResult = (lX And H3FFFFFFF) + (lY And H3FFFFFFF)

    If lX4 And lY4 Then
        lResult = lResult Xor H80000000 Xor lX8 Xor lY8
    ElseIf lX4 or lY4 Then
        If lResult And H40000000 Then
            lResult = lResult Xor HC0000000 Xor lX8 Xor lY8
        Else
            lResult = lResult Xor H40000000 Xor lX8 Xor lY8
        End If
    Else
        lResult = lResult Xor lX8 Xor lY8
    End If

    AddUnsigned = lResult
End Function

Private Function Ch(x, y, z)
    Ch = ((x And y) Xor ((Not x) And z))
End Function

Private Function Maj(x, y, z)
    Maj = ((x And y) Xor (x And z) Xor (y And z))
End Function

Private Function S(x, n)
    S = (RShift(x, (n And m_lOnBits(4))) or LShift(x, (32 - (n And m_lOnBits(4)))))
End Function

Private Function R(x, n)
    R = RShift(x, CInt(n And m_lOnBits(4)))
End Function

Private Function Sigma0(x)
    Sigma0 = (S(x, 2) Xor S(x, 13) Xor S(x, 22))
End Function

Private Function Sigma1(x)
    Sigma1 = (S(x, 6) Xor S(x, 11) Xor S(x, 25))
End Function

Private Function Gamma0(x)
    Gamma0 = (S(x, 7) Xor S(x, 18) Xor R(x, 3))
End Function

Private Function Gamma1(x)
    Gamma1 = (S(x, 17) Xor S(x, 19) Xor R(x, 10))
End Function

Private Function ConvertToWordArray(sMessage)
    Dim lMessageLength
    Dim lNumberOfWords
    Dim lWordArray()
    Dim lBytePosition
    Dim lByteCount
    Dim lWordCount
    Dim lByte

    Const MODULUS_BITS = 512
    Const CONGRUENT_BITS = 448

    lMessageLength = Len(sMessage)

    lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS) BITS_TO_A_BYTE)) (MODULUS_BITS BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS BITS_TO_A_WORD)
    ReDim lWordArray(lNumberOfWords - 1)

    lBytePosition = 0
    lByteCount = 0
    Do Until lByteCount >= lMessageLength
        lWordCount = lByteCount BYTES_TO_A_WORD

        lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE

        lByte = AscB(Mid(sMessage, lByteCount + 1, 1))

        lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(lByte, lBytePosition)
        lByteCount = lByteCount + 1
    Loop

    lWordCount = lByteCount BYTES_TO_A_WORD
    lBytePosition = (3 - (lByteCount Mod BYTES_TO_A_WORD)) * BITS_TO_A_BYTE

    lWordArray(lWordCount) = lWordArray(lWordCount) or LShift(H80, lBytePosition)

    lWordArray(lNumberOfWords - 1) = LShift(lMessageLength, 3)
    lWordArray(lNumberOfWords - 2) = RShift(lMessageLength, 29)

    ConvertToWordArray = lWordArray
End Function

Public Function SHA256(sMessage)
    Dim HASH(7)
    Dim M
    Dim W(63)
    Dim a
    Dim b
    Dim c
    Dim d
    Dim e
    Dim f
    Dim g
    Dim h
    Dim i
    Dim j
    Dim T1
    Dim T2

    HASH(0) = H6A09E667
    HASH(1) = HBB67AE85
    HASH(2) = H3C6EF372
    HASH(3) = HA54FF53A
    HASH(4) = H510E527F
    HASH(5) = H9B05688C
    HASH(6) = H1F83D9AB
    HASH(7) = H5BE0CD19

    M = ConvertToWordArray(sMessage)

    For i = 0 To UBound(M) Step 16
        a = HASH(0)
        b = HASH(1)
        c = HASH(2)
        d = HASH(3)
        e = HASH(4)
        f = HASH(5)
        g = HASH(6)
        h = HASH(7)

        For j = 0 To 63
            If j  16 Then
                W(j) = M(j + i)
            Else
                W(j) = AddUnsigned(AddUnsigned(AddUnsigned(Gamma1(W(j - 2)), W(j - 7)), Gamma0(W(j - 15))), W(j - 16))
            End If

            T1 = AddUnsigned(AddUnsigned(AddUnsigned(AddUnsigned(h, Sigma1(e)), Ch(e, f, g)), K(j)), W(j))
            T2 = AddUnsigned(Sigma0(a), Maj(a, b, c))

            h = g
            g = f
            f = e
            e = AddUnsigned(d, T1)
            d = c
            c = b
            b = a
            a = AddUnsigned(T1, T2)
        Next

        HASH(0) = AddUnsigned(a, HASH(0))
        HASH(1) = AddUnsigned(b, HASH(1))
        HASH(2) = AddUnsigned(c, HASH(2))
        HASH(3) = AddUnsigned(d, HASH(3))
        HASH(4) = AddUnsigned(e, HASH(4))
        HASH(5) = AddUnsigned(f, HASH(5))
        HASH(6) = AddUnsigned(g, HASH(6))
        HASH(7) = AddUnsigned(h, HASH(7))
    Next

    SHA256 = LCase(Right("00000000"  Hex(HASH(0)), 8)  Right("00000000"  Hex(HASH(1)), 8)  Right("00000000"  Hex(HASH(2)), 8)  Right("00000000"  Hex(HASH(3)), 8)  Right("00000000"  Hex(HASH(4)), 8)  Right("00000000"  Hex(HASH(5)), 8)  Right("00000000"  Hex(HASH(6)), 8)  Right("00000000"  Hex(HASH(7)), 8))
End Function

6.一個(gè)If語(yǔ)句的加工，以后可以用類(lèi)似于PHP或JS的 If () ? ..
...代碼了

Function IIf(Condition, ValueIfTrue, ValueIfFalse)
    If Condition Then
        IIf = ValueIfTrue
    Else
        IIf = ValueIfFalse
    End If
End Function

7.ASE加密函數(shù)
Private m_lOnBits(30)
Private m_l2Power(30)
Private m_bytOnBits(7)
Private m_byt2Power(7)

Private m_InCo(3)

Private m_fbsub(255)
Private m_rbsub(255)
Private m_ptab(255)
Private m_ltab(255)
Private m_ftable(255)
Private m_rtable(255)
Private m_rco(29)

Private m_Nk
Private m_Nb
Private m_Nr
Private m_fi(23)
Private m_ri(23)
Private m_fkey(119)
Private m_rkey(119)

m_InCo(0) = HB
m_InCo(1) = HD
m_InCo(2) = H9
m_InCo(3) = HE

m_bytOnBits(0) = 1
m_bytOnBits(1) = 3
m_bytOnBits(2) = 7
m_bytOnBits(3) = 15
m_bytOnBits(4) = 31
m_bytOnBits(5) = 63
m_bytOnBits(6) = 127
m_bytOnBits(7) = 255

m_byt2Power(0) = 1
m_byt2Power(1) = 2
m_byt2Power(2) = 4
m_byt2Power(3) = 8
m_byt2Power(4) = 16
m_byt2Power(5) = 32
m_byt2Power(6) = 64
m_byt2Power(7) = 128

m_lOnBits(0) = 1
m_lOnBits(1) = 3
m_lOnBits(2) = 7
m_lOnBits(3) = 15
m_lOnBits(4) = 31
m_lOnBits(5) = 63
m_lOnBits(6) = 127
m_lOnBits(7) = 255
m_lOnBits(8) = 511
m_lOnBits(9) = 1023
m_lOnBits(10) = 2047
m_lOnBits(11) = 4095
m_lOnBits(12) = 8191
m_lOnBits(13) = 16383
m_lOnBits(14) = 32767
m_lOnBits(15) = 65535
m_lOnBits(16) = 131071
m_lOnBits(17) = 262143
m_lOnBits(18) = 524287
m_lOnBits(19) = 1048575
m_lOnBits(20) = 2097151
m_lOnBits(21) = 4194303
m_lOnBits(22) = 8388607
m_lOnBits(23) = 16777215
m_lOnBits(24) = 33554431
m_lOnBits(25) = 67108863
m_lOnBits(26) = 134217727
m_lOnBits(27) = 268435455
m_lOnBits(28) = 536870911
m_lOnBits(29) = 1073741823
m_lOnBits(30) = 2147483647

m_l2Power(0) = 1
m_l2Power(1) = 2
m_l2Power(2) = 4
m_l2Power(3) = 8
m_l2Power(4) = 16
m_l2Power(5) = 32
m_l2Power(6) = 64
m_l2Power(7) = 128
m_l2Power(8) = 256
m_l2Power(9) = 512
m_l2Power(10) = 1024
m_l2Power(11) = 2048
m_l2Power(12) = 4096
m_l2Power(13) = 8192
m_l2Power(14) = 16384
m_l2Power(15) = 32768
m_l2Power(16) = 65536
m_l2Power(17) = 131072
m_l2Power(18) = 262144
m_l2Power(19) = 524288
m_l2Power(20) = 1048576
m_l2Power(21) = 2097152
m_l2Power(22) = 4194304
m_l2Power(23) = 8388608
m_l2Power(24) = 16777216
m_l2Power(25) = 33554432
m_l2Power(26) = 67108864
m_l2Power(27) = 134217728
m_l2Power(28) = 268435456
m_l2Power(29) = 536870912
m_l2Power(30) = 1073741824

Private Function LShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        LShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And 1 Then
            LShift = H80000000
        Else
            LShift = 0
        End If
        Exit Function
    ElseIf iShiftBits  0 or iShiftBits > 31 Then
        Err.Raise 6
    End If

    If (lValue And m_l2Power(31 - iShiftBits)) Then
        LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) or H80000000
    Else
        LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
    End If
End Function

Private Function RShift(lValue, iShiftBits)
    If iShiftBits = 0 Then
        RShift = lValue
        Exit Function
    ElseIf iShiftBits = 31 Then
        If lValue And H80000000 Then
            RShift = 1
        Else
            RShift = 0
        End If
        Exit Function
    ElseIf iShiftBits  0 or iShiftBits > 31 Then
        Err.Raise 6
    End If

    RShift = (lValue And H7FFFFFFE) m_l2Power(iShiftBits)

    If (lValue And H80000000) Then
        RShift = (RShift or (H40000000 m_l2Power(iShiftBits - 1)))
    End If
End Function

Private Function LShiftByte(bytValue, bytShiftBits)
    If bytShiftBits = 0 Then
        LShiftByte = bytValue
        Exit Function
    ElseIf bytShiftBits = 7 Then
        If bytValue And 1 Then
            LShiftByte = H80
        Else
            LShiftByte = 0
        End If
        Exit Function
    ElseIf bytShiftBits  0 or bytShiftBits > 7 Then
        Err.Raise 6
    End If

    LShiftByte = ((bytValue And m_bytOnBits(7 - bytShiftBits)) * m_byt2Power(bytShiftBits))
End Function

Private Function RShiftByte(bytValue, bytShiftBits)
    If bytShiftBits = 0 Then
        RShiftByte = bytValue
        Exit Function
    ElseIf bytShiftBits = 7 Then
        If bytValue And H80 Then
            RShiftByte = 1
        Else
            RShiftByte = 0
        End If
        Exit Function
    ElseIf bytShiftBits  0 or bytShiftBits > 7 Then
        Err.Raise 6
    End If

    RShiftByte = bytValue m_byt2Power(bytShiftBits)
End Function

Private Function RotateLeft(lValue, iShiftBits)
    RotateLeft = LShift(lValue, iShiftBits) or RShift(lValue, (32 - iShiftBits))
End Function

Private Function RotateLeftByte(bytValue, bytShiftBits)
    RotateLeftByte = LShiftByte(bytValue, bytShiftBits) or RShiftByte(bytValue, (8 - bytShiftBits))
End Function

Private Function Pack(b())
    Dim lCount
    Dim lTemp

    For lCount = 0 To 3
        lTemp = b(lCount)
        Pack = Pack or LShift(lTemp, (lCount * 8))
    Next
End Function

Private Function PackFrom(b(), k)
    Dim lCount
    Dim lTemp

    For lCount = 0 To 3
        lTemp = b(lCount + k)
        PackFrom = PackFrom or LShift(lTemp, (lCount * 8))
    Next
End Function

Private Sub Unpack(a, b())
    b(0) = a And m_lOnBits(7)
    b(1) = RShift(a, 8) And m_lOnBits(7)
    b(2) = RShift(a, 16) And m_lOnBits(7)
    b(3) = RShift(a, 24) And m_lOnBits(7)
End Sub

Private Sub UnpackFrom(a, b(), k)
    b(0 + k) = a And m_lOnBits(7)
    b(1 + k) = RShift(a, 8) And m_lOnBits(7)
    b(2 + k) = RShift(a, 16) And m_lOnBits(7)
    b(3 + k) = RShift(a, 24) And m_lOnBits(7)
End Sub

Private Function xtime(a)
    Dim b

    If (a And H80) Then
        b = H1B
    Else
        b = 0
    End If

    xtime = LShiftByte(a, 1)
    xtime = xtime Xor b
End Function

Private Function bmul(x, y)
    If x > 0 And y > 0 Then
        bmul = m_ptab((CLng(m_ltab(x)) + CLng(m_ltab(y))) Mod 255)
    Else
        bmul = 0
    End If
End Function

Private Function SubByte(a)
    Dim b(3)

    Unpack a, b
    b(0) = m_fbsub(b(0))
    b(1) = m_fbsub(b(1))
    b(2) = m_fbsub(b(2))
    b(3) = m_fbsub(b(3))

    SubByte = Pack(b)
End Function

Private Function product(x, y)
    Dim xb(3)
    Dim yb(3)

    Unpack x, xb
    Unpack y, yb
    product = bmul(xb(0), yb(0)) Xor bmul(xb(1), yb(1)) Xor bmul(xb(2), yb(2)) Xor bmul(xb(3), yb(3))
End Function

Private Function InvMixCol(x)
    Dim y
    Dim m
    Dim b(3)

    m = Pack(m_InCo)
    b(3) = product(m, x)
    m = RotateLeft(m, 24)
    b(2) = product(m, x)
    m = RotateLeft(m, 24)
    b(1) = product(m, x)
    m = RotateLeft(m, 24)
    b(0) = product(m, x)
    y = Pack(b)

    InvMixCol = y
End Function

Private Function ByteSub(x)
    Dim y
    Dim z

    z = x
    y = m_ptab(255 - m_ltab(z))
    z = y
    z = RotateLeftByte(z, 1)
    y = y Xor z
    z = RotateLeftByte(z, 1)
    y = y Xor z
    z = RotateLeftByte(z, 1)
    y = y Xor z
    z = RotateLeftByte(z, 1)
    y = y Xor z
    y = y Xor H63

    ByteSub = y
End Function

Public Sub gentables()
    Dim i
    Dim y
    Dim b(3)
    Dim ib

    m_ltab(0) = 0
    m_ptab(0) = 1
    m_ltab(1) = 0
    m_ptab(1) = 3
    m_ltab(3) = 1

    For i = 2 To 255
        m_ptab(i) = m_ptab(i - 1) Xor xtime(m_ptab(i - 1))
        m_ltab(m_ptab(i)) = i
    Next

    m_fbsub(0) = H63
    m_rbsub(H63) = 0

    For i = 1 To 255
        ib = i
        y = ByteSub(ib)
        m_fbsub(i) = y
        m_rbsub(y) = i
    Next

    y = 1
    For i = 0 To 29
        m_rco(i) = y
        y = xtime(y)
    Next

    For i = 0 To 255
        y = m_fbsub(i)
        b(3) = y Xor xtime(y)
        b(2) = y
        b(1) = y
        b(0) = xtime(y)
        m_ftable(i) = Pack(b)

        y = m_rbsub(i)
        b(3) = bmul(m_InCo(0), y)
        b(2) = bmul(m_InCo(1), y)
        b(1) = bmul(m_InCo(2), y)
        b(0) = bmul(m_InCo(3), y)
        m_rtable(i) = Pack(b)
    Next
End Sub

Public Sub gkey(nb, nk, Key())
    Dim i
    Dim j
    Dim k
    Dim m
    Dim N
    Dim C1
    Dim C2
    Dim C3
    Dim CipherKey(7)

    m_Nb = nb
    m_Nk = nk

    If m_Nb >= m_Nk Then
        m_Nr = 6 + m_Nb
    Else
        m_Nr = 6 + m_Nk
    End If

    C1 = 1
    If m_Nb  8 Then
        C2 = 2
        C3 = 3
    Else
        C2 = 3
        C3 = 4
    End If

    For j = 0 To nb - 1
        m = j * 3

        m_fi(m) = (j + C1) Mod nb
        m_fi(m + 1) = (j + C2) Mod nb
        m_fi(m + 2) = (j + C3) Mod nb
        m_ri(m) = (nb + j - C1) Mod nb
        m_ri(m + 1) = (nb + j - C2) Mod nb
        m_ri(m + 2) = (nb + j - C3) Mod nb
    Next

    N = m_Nb * (m_Nr + 1)

    For i = 0 To m_Nk - 1
        j = i * 4
        CipherKey(i) = PackFrom(Key, j)
    Next

    For i = 0 To m_Nk - 1
        m_fkey(i) = CipherKey(i)
    Next

    j = m_Nk
    k = 0
    Do While j  N
        m_fkey(j) = m_fkey(j - m_Nk) Xor _
               SubByte(RotateLeft(m_fkey(j - 1), 24)) Xor m_rco(k)
        If m_Nk = 6 Then
            i = 1
            Do While i  m_Nk And (i + j)  N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                       m_fkey(i + j - 1)
                i = i + 1
            Loop
        Else
            i = 1
            Do While i  4 And (i + j)  N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                       m_fkey(i + j - 1)
                i = i + 1
            Loop
            If j + 4  N Then
                m_fkey(j + 4) = m_fkey(j + 4 - m_Nk) Xor _
                       SubByte(m_fkey(j + 3))
            End If
            i = 5
            Do While i  m_Nk And (i + j)  N
                m_fkey(i + j) = m_fkey(i + j - m_Nk) Xor _
                       m_fkey(i + j - 1)
                i = i + 1
            Loop
        End If

        j = j + m_Nk
        k = k + 1
    Loop

    For j = 0 To m_Nb - 1
        m_rkey(j + N - nb) = m_fkey(j)
    Next

    i = m_Nb
    Do While i  N - m_Nb
        k = N - m_Nb - i
        For j = 0 To m_Nb - 1
            m_rkey(k + j) = InvMixCol(m_fkey(i + j))
        Next
        i = i + m_Nb
    Loop

    j = N - m_Nb
    Do While j  N
        m_rkey(j - N + m_Nb) = m_fkey(j)
        j = j + 1
    Loop
End Sub

Public Sub encrypt(buff())
    Dim i
    Dim j
    Dim k
    Dim m
    Dim a(7)
    Dim b(7)
    Dim x
    Dim y
    Dim t

    For i = 0 To m_Nb - 1
        j = i * 4

        a(i) = PackFrom(buff, j)
        a(i) = a(i) Xor m_fkey(i)
    Next

    k = m_Nb
    x = a
    y = b

    For i = 1 To m_Nr - 1
        For j = 0 To m_Nb - 1
            m = j * 3
            y(j) = m_fkey(k) Xor m_ftable(x(j) And m_lOnBits(7)) Xor _
              RotateLeft(m_ftable(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
              RotateLeft(m_ftable(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
              RotateLeft(m_ftable(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
            k = k + 1
        Next
        t = x
        x = y
        y = t
    Next

    For j = 0 To m_Nb - 1
        m = j * 3
        y(j) = m_fkey(k) Xor m_fbsub(x(j) And m_lOnBits(7)) Xor _
          RotateLeft(m_fbsub(RShift(x(m_fi(m)), 8) And m_lOnBits(7)), 8) Xor _
          RotateLeft(m_fbsub(RShift(x(m_fi(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
          RotateLeft(m_fbsub(RShift(x(m_fi(m + 2)), 24) And m_lOnBits(7)), 24)
        k = k + 1
    Next

    For i = 0 To m_Nb - 1
        j = i * 4
        UnpackFrom y(i), buff, j
        x(i) = 0
        y(i) = 0
    Next
End Sub

Public Sub decrypt(buff())
    Dim i
    Dim j
    Dim k
    Dim m
    Dim a(7)
    Dim b(7)
    Dim x
    Dim y
    Dim t

    For i = 0 To m_Nb - 1
        j = i * 4
        a(i) = PackFrom(buff, j)
        a(i) = a(i) Xor m_rkey(i)
    Next

    k = m_Nb
    x = a
    y = b

    For i = 1 To m_Nr - 1
        For j = 0 To m_Nb - 1
            m = j * 3
            y(j) = m_rkey(k) Xor m_rtable(x(j) And m_lOnBits(7)) Xor _
              RotateLeft(m_rtable(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
              RotateLeft(m_rtable(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
              RotateLeft(m_rtable(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
            k = k + 1
        Next
        t = x
        x = y
        y = t
    Next

    For j = 0 To m_Nb - 1
        m = j * 3

        y(j) = m_rkey(k) Xor m_rbsub(x(j) And m_lOnBits(7)) Xor _
          RotateLeft(m_rbsub(RShift(x(m_ri(m)), 8) And m_lOnBits(7)), 8) Xor _
          RotateLeft(m_rbsub(RShift(x(m_ri(m + 1)), 16) And m_lOnBits(7)), 16) Xor _
          RotateLeft(m_rbsub(RShift(x(m_ri(m + 2)), 24) And m_lOnBits(7)), 24)
        k = k + 1
    Next

    For i = 0 To m_Nb - 1
        j = i * 4

        UnpackFrom y(i), buff, j
        x(i) = 0
        y(i) = 0
    Next
End Sub

Private Function IsInitialized(vArray)
    On Error Resume Next

    IsInitialized = IsNumeric(UBound(vArray))
End Function

Private Sub CopyBytesASP(bytDest, lDestStart, bytSource(), lSourceStart, lLength)
    Dim lCount

    lCount = 0
    Do
        bytDest(lDestStart + lCount) = bytSource(lSourceStart + lCount)
        lCount = lCount + 1
    Loop Until lCount = lLength
End Sub

Public Function EncryptData(bytMessage, bytPassword)
    Dim bytKey(31)
    Dim bytIn()
    Dim bytOut()
    Dim bytTemp(31)
    Dim lCount
    Dim lLength
    Dim lEncodedLength
    Dim bytLen(3)
    Dim lPosition

    If Not IsInitialized(bytMessage) Then
        Exit Function
    End If
    If Not IsInitialized(bytPassword) Then
        Exit Function
    End If

    For lCount = 0 To UBound(bytPassword)
        bytKey(lCount) = bytPassword(lCount)
        If lCount = 31 Then
            Exit For
        End If
    Next

    gentables
    gkey 8, 8, bytKey

    lLength = UBound(bytMessage) + 1
    lEncodedLength = lLength + 4

    If lEncodedLength Mod 32 > 0 Then
        lEncodedLength = lEncodedLength + 32 - (lEncodedLength Mod 32)
    End If
    ReDim bytIn(lEncodedLength - 1)
    ReDim bytOut(lEncodedLength - 1)

    Unpack lLength, bytIn
    CopyBytesASP bytIn, 4, bytMessage, 0, lLength

    For lCount = 0 To lEncodedLength - 1 Step 32
        CopyBytesASP bytTemp, 0, bytIn, lCount, 32
        Encrypt bytTemp
        CopyBytesASP bytOut, lCount, bytTemp, 0, 32
    Next

    EncryptData = bytOut
End Function

Public Function DecryptData(bytIn, bytPassword)
    Dim bytMessage()
    Dim bytKey(31)
    Dim bytOut()
    Dim bytTemp(31)
    Dim lCount
    Dim lLength
    Dim lEncodedLength
    Dim bytLen(3)
    Dim lPosition

    If Not IsInitialized(bytIn) Then
        Exit Function
    End If
    If Not IsInitialized(bytPassword) Then
        Exit Function
    End If

    lEncodedLength = UBound(bytIn) + 1

    If lEncodedLength Mod 32 > 0 Then
        Exit Function
    End If

    For lCount = 0 To UBound(bytPassword)
        bytKey(lCount) = bytPassword(lCount)
        If lCount = 31 Then
            Exit For
        End If
    Next

    gentables
    gkey 8, 8, bytKey

    ReDim bytOut(lEncodedLength - 1)

    For lCount = 0 To lEncodedLength - 1 Step 32
        CopyBytesASP bytTemp, 0, bytIn, lCount, 32
        Decrypt bytTemp
        CopyBytesASP bytOut, lCount, bytTemp, 0, 32
    Next

    lLength = Pack(bytOut)

    If lLength > lEncodedLength - 4 Then
        Exit Function
    End If

    ReDim bytMessage(lLength - 1)
    CopyBytesASP bytMessage, 0, bytOut, 4, lLength

    DecryptData = bytMessage
End Function

8.一個(gè)日期轉(zhuǎn)換函數(shù)

Function FormatDate(byVal strDate, byVal strFormat)

    ' Accepts strDate as a valid date/time,
    ' strFormat as the output template.
    ' The function finds each item in the
    ' template and replaces it with the
    ' relevant information extracted from strDate.
    ' You are free to use this code provided the following line remains
    ' www.adopenstatic.com/resources/code/formatdate.asp

    ' Template items
    ' %m Month as a decimal no. 2
    ' %M Month as a padded decimal no. 02
    ' %B Full month name February
    ' %b Abbreviated month name Feb
    ' %d Day of the month eg 23
    ' %D Padded day of the month eg 09
    ' %O ordinal of day of month (eg st or rd or nd)
    ' %j Day of the year 54
    ' %Y Year with century 1998
    ' %y Year without century 98
    ' %w Weekday as integer (0 is Sunday)
    ' %a Abbreviated day name Fri
    ' %A Weekday Name Friday
    ' %H Hour in 24 hour format 24
    ' %h Hour in 12 hour format 12
    ' %N Minute as an integer 01
    ' %n Minute as optional if minute > 00
    ' %S Second as an integer 55
    ' %P AM/PM Indicator PM

    On Error Resume Next

    Dim intPosItem
    Dim int12HourPart
    Dim str24HourPart
    Dim strMinutePart
    Dim strSecondPart
    Dim strAMPM

    ' Insert Month Numbers
    strFormat = Replace(strFormat, "%m", DatePart("m", strDate), 1, -1, vbBinaryCompare)

    ' Insert Padded Month Numbers
    strFormat = Replace(strFormat, "%M", Right("0"  DatePart("m", strDate), 2), 1, -1, vbBinaryCompare)

    ' Insert non-Abbreviated Month Names
    strFormat = Replace(strFormat, "%B", MonthName(DatePart("m", strDate), False), 1, -1, vbBinaryCompare)

    ' Insert Abbreviated Month Names
    strFormat = Replace(strFormat, "%b", MonthName(DatePart("m", strDate), True), 1, -1, vbBinaryCompare)

    ' Insert Day Of Month
    strFormat = Replace(strFormat, "%d", DatePart("d", strDate), 1, -1, vbBinaryCompare)

    ' Insert Padded Day Of Month
    strFormat = Replace(strFormat, "%D", Right ("0"  DatePart("d", strDate), 2), 1, -1, vbBinaryCompare)

    ' Insert Day of Month ordinal (eg st, th, or rd)
    strFormat = Replace(strFormat, "%O", GetDayOrdinal(Day(strDate)), 1, -1, vbBinaryCompare)

    ' Insert Day of Year
    strFormat = Replace(strFormat, "%j", DatePart("y", strDate), 1, -1, vbBinaryCompare)

    ' Insert Long Year (4 digit)
    strFormat = Replace(strFormat, "%Y", DatePart("yyyy", strDate), 1, -1, vbBinaryCompare)

    ' Insert Short Year (2 digit)
    strFormat = Replace(strFormat, "%y", Right(DatePart("yyyy", strDate), 2), 1, -1, vbBinaryCompare)

    ' Insert Weekday as Integer (eg 0 = Sunday)
    strFormat = Replace(strFormat, "%w", DatePart("w", strDate, 1), 1, -1, vbBinaryCompare)

    ' Insert Abbreviated Weekday Name (eg Sun)
    strFormat = Replace(strFormat, "%a", WeekdayName(DatePart("w", strDate, 1), True), 1, -1, vbBinaryCompare)

    ' Insert non-Abbreviated Weekday Name
    strFormat = Replace(strFormat, "%A", WeekdayName(DatePart("w", strDate, 1), False), 1, -1, vbBinaryCompare)

    ' Insert Hour in 24hr format
    str24HourPart = DatePart("h", strDate)
    If Len(str24HourPart)  2 Then str24HourPart = "0"  str24HourPart
    strFormat = Replace(strFormat, "%H", str24HourPart, 1, -1, vbBinaryCompare)

    ' Insert Hour in 12hr format
    int12HourPart = DatePart("h", strDate) Mod 12
    If int12HourPart = 0 Then int12HourPart = 12
    strFormat = Replace(strFormat, "%h", int12HourPart, 1, -1, vbBinaryCompare)

    ' Insert Minutes
    strMinutePart = DatePart("n", strDate)
    If Len(strMinutePart)  2 Then strMinutePart = "0"  strMinutePart
    strFormat = Replace(strFormat, "%N", strMinutePart, 1, -1, vbBinaryCompare)

    ' Insert Optional Minutes
    If CInt(strMinutePart) = 0 Then
        strFormat = Replace(strFormat, "%n", "", 1, -1, vbBinaryCompare)
    Else
        If CInt(strMinutePart)  10 Then strMinutePart = "0"  strMinutePart
        strMinutePart = ":"  strMinutePart
        strFormat = Replace(strFormat, "%n", strMinutePart, 1, -1, vbBinaryCompare)
    End If

    ' Insert Seconds
    strSecondPart = DatePart("s", strDate)
    If Len(strSecondPart)  2 Then strSecondPart = "0"  strSecondPart
    strFormat = Replace(strFormat, "%S", strSecondPart, 1, -1, vbBinaryCompare)

    ' Insert AM/PM indicator
    If DatePart("h", strDate) >= 12 Then
        strAMPM = "PM"
    Else
        strAMPM = "AM"
    End If

    strFormat = Replace(strFormat, "%P", strAMPM, 1, -1, vbBinaryCompare)

    FormatDate = strFormat

End Function

Function GetDayOrdinal( _
                       byVal intDay _
                       )

    ' Accepts a day of the month
    ' as an integer and returns the
    ' appropriate suffix
    On Error Resume Next

    Dim strOrd

    Select Case intDay
        Case 1, 21, 31
            strOrd = "st"
        Case 2, 22
            strOrd = "nd"
        Case 3, 23
            strOrd = "rd"
        Case Else
            strOrd = "th"
    End Select

    GetDayOrdinal = strOrd

End Function
%>
%
Dim db
db = "dbms.mdb"

'******************************************************************
'執(zhí)行sql語(yǔ)句，不返回值,sql語(yǔ)句最好是如下：
'update 表名 set 字段名=value,字段名=value where 字段名=value
'delete from 表名 where 字段名=value
'insert into 表名 (字段名,字段名) values (value,value)
'******************************************************************

Sub NoResult(sql)
    Dim conn
    Dim connstr
    Set conn = Server.CreateObject("ADODB.Connection")
    connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="  Server.MapPath(""db"")
    conn.Open connstr
    conn.Execute sql
    conn.Close
    Set conn = Nothing
End Sub

'*******************************************************************
'執(zhí)行select語(yǔ)句，返回recordset對(duì)象。該對(duì)象只讀。也就是不能更新
'*******************************************************************

Function Result(sql)
    Dim conn
    Dim connstr
    Dim rcs
    Set conn = Server.CreateObject("ADODB.Connection")
    connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="  Server.MapPath(""db"")
    conn.Open connstr
    Set rcs = Server.CreateObject("ADODB.Recordset")
    rcs.Open sql, conn, 1, 1
    Set Result = rcs
End Function

'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************

Sub alert(message)
    message = Replace(message, "'", "\'")
    Response.Write ("script>alert('"  message  "')/script>")
End Sub

'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************

Sub GoBack()
    Response.Write ("script>history.go(-1)/script>")
End Sub

'*******************************************************************
' 重定向另外的連接
'*******************************************************************

Sub Go(url)
    Response.Write ("script>location.href('"  url  "')/script>")
End Sub

'*******************************************************************
' 把html標(biāo)記替換
'*******************************************************************

Function htmlencode2(Str)
    Dim result
    Dim l
    If IsNull(Str) Then
        htmlencode2 = ""
        Exit Function
    End If
    l = Len(Str)
    result = ""
    Dim i
    For i = 1 To l
        Select Case Mid(Str, i, 1)
            Case ""
                result = result + ""
            Case ">"
                result = result + ">"
            Case Chr(13)
                result = result + "br>"
            Case Chr(34)
                result = result + """%>
%
cLeft(String, Length) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。

如：
Dim MyString, LeftString
MyString = "文字測(cè)試VBSCript"
LeftString = cLeft(MyString, 10)
返回 "文字測(cè)試VB"。

MyRandc(n) 生成隨機(jī)字符，n為字符的個(gè)數(shù)

如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)字符

MyRandn(n) 生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)

如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)數(shù)字

formatQueryStr(Str) 格式化sql中的like字符串.
如：
q = Request("q")
q = formatQueryStr(q)
sql = "select * from [table] where aa like '%" q "%'"

GetRnd(min, max)　返回min - max之間的一個(gè)隨機(jī)數(shù)

如：
response.Write GetRnd(100, 200)
輸出大于100到200之間的一個(gè)隨機(jī)數(shù)

Function cLeft(Str, n)
    Dim str1, str2, alln, Islefted
    str2 = ""
    alln = 0
    str1 = Str
    Islefted = False
    If IsNull(Str) Then
        cleft = ""
        Exit Function
    End If
    For i = 1 To Len(str1)
        nowstr = Mid(str1, i, 1)
        If Asc(nowstr)0 Then
            alln = alln + 2
        Else
            alln = alln + 1
        End If
        If (alln= n) Then
            str2 = str2  nowstr
        Else
            Islefted = True
            Exit For
        End If
    Next
    If Islefted Then
        str2 = str2  ".."
    End If
    cleft = str2
End Function

Function MyRandc(n) '生成隨機(jī)字符，n為字符的個(gè)數(shù)
    Dim thechr
    thechr = ""
    For i = 1 To n
        Dim zNum, zNum2
        Randomize
        zNum = CInt(25 * Rnd)
        zNum2 = CInt(10 * Rnd)
        If zNum2 Mod 2 = 0 Then
            zNum = zNum + 97
        Else
            zNum = zNum + 65
        End If
        thechr = thechr  Chr(zNum)
    Next
    MyRandc = thechr
End Function

Function MyRandn(n) '生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
    Dim thechr
    thechr = ""
    For i = 1 To n
        Dim zNum, zNum2
        Randomize
        zNum = CInt(9 * Rnd)
        zNum = zNum + 48
        thechr = thechr  Chr(zNum)
    Next
    MyRandn = thechr
End Function

Function formatQueryStr(Str) '格式化sql中的like字符串
    Dim nstr
    nstr = Str
    nstr = Replace(nstr, Chr(0), "")
    nstr = Replace(nstr, "'", "''")
    nstr = Replace(nstr, "[", "[[]")
    nstr = Replace(nstr, "%", "[%]")
    formatQueryStr = nstr
End Function

Function GetRnd(min, max)
    Randomize
    GetRnd = Int((max - min + 1) * Rnd + min)
End Function

'*******************************************************************
'取得IP地址
'*******************************************************************

Function Userip()
    Dim GetClientIP
    '如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
    GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
    If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
        '如果客戶端沒(méi)用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
        GetClientIP = Request.ServerVariables("REMOTE_ADDR")
    End If
    Userip = GetClientIP
End Function

'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************

Function cip(sip)
    tip = CStr(sip)
    sip1 = Left(tip, CInt(InStr(tip, ".") -1))
    tip = Mid(tip, CInt(InStr(tip, ".") + 1))
    sip2 = Left(tip, CInt(InStr(tip, ".") -1))
    tip = Mid(tip, CInt(InStr(tip, ".") + 1))
    sip3 = Left(tip, CInt(InStr(tip, ".") -1))
    sip4 = Mid(tip, CInt(InStr(tip, ".") + 1))
    cip = CInt(sip1) * 256 * 256 * 256 + CInt(sip2) * 256 * 256 + CInt(sip3) * 256 + CInt(sip4)
End Function

'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************

Sub alert(message)
    message = Replace(message, "'", "\'")
    Response.Write ("script>alert('"  message  "')/script>")
End Sub

'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************

Sub GoBack()
    Response.Write ("script>history.go(-1)/script>")
End Sub

'*******************************************************************
' 重定向另外的連接
'*******************************************************************

Sub Go(url)
    Response.Write ("script>location.href('"  url  "')/script>")
End Sub

'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************

Sub GoPage(url, s)
    s = s * 1000
    Response.Write "SCRIPT LANGUAGE=javascript>"
    Response.Write "window.setTimeout("Chr(34)"window.navigate('"url"')"Chr(34)","s")"
    Response.Write "/script>"
End Sub

'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************

Function isInteger(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

'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************

Function GetExtend(filename)
    Dim tmp
    If filename>"" Then
        tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
        tmp = LCase(tmp)
        If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
            getextend = "txt"
        Else
            getextend = tmp
        End If
    Else
        getextend = ""
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function CheckIn(Str)
    If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
        CheckIn = True
    Else
        CheckIn = False
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function HTMLEncode(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, Chr(10)  Chr(10), "/P>P> ")
        fString = Replace(fString, Chr(10), "BR> ")

        HTMLEncode = fString
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function HTMLcode(fString)
    If Not IsNull(fString) Then
        fString = Replace(fString, Chr(13), "")
        fString = Replace(fString, Chr(10)  Chr(10), "/P>P>")
        fString = Replace(fString, Chr(34), "")
        fString = Replace(fString, Chr(10), "BR>")
        HTMLcode = fString
    End If
End Function

%>
%
cLeft(String, Length) 返回指定數(shù)目的從字符串的左邊算起的字符，區(qū)分單雙字節(jié)。
如：
Dim MyString, LeftString
MyString = "文字測(cè)試VBSCript"
LeftString = cLeft(MyString, 10)
返回 "文字測(cè)試VB"。
MyRandc(n) 生成隨機(jī)字符，n為字符的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)字符
MyRandn(n) 生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
如：
response.Write MyRandn(10)
輸出10個(gè)隨機(jī)數(shù)字
formatQueryStr(Str) 格式化sql中的like字符串.
如：
q = Request("q")
q = formatQueryStr(q)
sql = "select * from [table] where aa like '%" q "%'"
GetRnd(min, max)　返回min - max之間的一個(gè)隨機(jī)數(shù)
如：
response.Write GetRnd(100, 200)
輸出大于100到200之間的一個(gè)隨機(jī)數(shù)

Function cLeft(Str, n)
    Dim str1, str2, alln, Islefted
    str2 = ""
    alln = 0
    str1 = Str
    Islefted = False
    If IsNull(Str) Then
        cleft = ""
        Exit Function
    End If
    For i = 1 To Len(str1)
        nowstr = Mid(str1, i, 1)
        If Asc(nowstr)0 Then
            alln = alln + 2
        Else
            alln = alln + 1
        End If
        If (alln= n) Then
            str2 = str2  nowstr
        Else
            Islefted = True
            Exit For
        End If
    Next
    If Islefted Then
        str2 = str2  ".."
    End If
    cleft = str2
End Function

Function MyRandc(n) '生成隨機(jī)字符，n為字符的個(gè)數(shù)
    Dim thechr
    thechr = ""
    For i = 1 To n
        Dim zNum, zNum2
        Randomize
        zNum = CInt(25 * Rnd)
        zNum2 = CInt(10 * Rnd)
        If zNum2 Mod 2 = 0 Then
            zNum = zNum + 97
        Else
            zNum = zNum + 65
        End If
        thechr = thechr  Chr(zNum)
    Next
    MyRandc = thechr
End Function

Function MyRandn(n) '生成隨機(jī)數(shù)字，n為數(shù)字的個(gè)數(shù)
    Dim thechr
    thechr = ""
    For i = 1 To n
        Dim zNum, zNum2
        Randomize
        zNum = CInt(9 * Rnd)
        zNum = zNum + 48
        thechr = thechr  Chr(zNum)
    Next
    MyRandn = thechr
End Function

Function formatQueryStr(Str) '格式化sql中的like字符串
    Dim nstr
    nstr = Str
    nstr = Replace(nstr, Chr(0), "")
    nstr = Replace(nstr, "'", "''")
    nstr = Replace(nstr, "[", "[[]")
    nstr = Replace(nstr, "%", "[%]")
    formatQueryStr = nstr
End Function

Function GetRnd(min, max)
    Randomize
    GetRnd = Int((max - min + 1) * Rnd + min)
End Function

'*******************************************************************
'取得IP地址
'*******************************************************************

Function Userip()
    Dim GetClientIP
    '如果客戶端用了代理服務(wù)器，則應(yīng)該用ServerVariables("HTTP_X_FORWARDED_FOR")方法
    GetClientIP = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
    If GetClientIP = "" or IsNull(GetClientIP) or IsEmpty(GetClientIP) Then
        '如果客戶端沒(méi)用代理，應(yīng)該用Request.ServerVariables("REMOTE_ADDR")方法
        GetClientIP = Request.ServerVariables("REMOTE_ADDR")
    End If
    Userip = GetClientIP
End Function

'*******************************************************************
'轉(zhuǎn)換IP地址
'*******************************************************************

Function cip(sip)
    tip = CStr(sip)
    sip1 = Left(tip, CInt(InStr(tip, ".") -1))
    tip = Mid(tip, CInt(InStr(tip, ".") + 1))
    sip2 = Left(tip, CInt(InStr(tip, ".") -1))
    tip = Mid(tip, CInt(InStr(tip, ".") + 1))
    sip3 = Left(tip, CInt(InStr(tip, ".") -1))
    sip4 = Mid(tip, CInt(InStr(tip, ".") + 1))
    cip = CInt(sip1) * 256 * 256 * 256 + CInt(sip2) * 256 * 256 + CInt(sip3) * 256 + CInt(sip4)
End Function

'*******************************************************************
' 彈出對(duì)話框
'*******************************************************************

Sub alert(message)
    message = Replace(message, "'", "\'")
    Response.Write ("script>alert('"  message  "')/script>")
End Sub

'*******************************************************************
' 返回上一頁(yè)，一般用在判斷信息提交是否完全之后
'*******************************************************************

Sub GoBack()
    Response.Write ("script>history.go(-1)/script>")
End Sub

'*******************************************************************
' 重定向另外的連接
'*******************************************************************

Sub Go(url)
    Response.Write ("script>location.href('"  url  "')/script>")
End Sub

'*******************************************************************
' 指定秒數(shù)重定向另外的連接
'*******************************************************************

Sub GoPage(url, s)
    s = s * 1000
    Response.Write "SCRIPT LANGUAGE=javascript>"
    Response.Write "window.setTimeout("Chr(34)"window.navigate('"url"')"Chr(34)","s")"
    Response.Write "/script>"
End Sub

'*******************************************************************
' 判斷數(shù)字是否整形
'*******************************************************************

Function isInteger(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

'*******************************************************************
' 獲得文件擴(kuò)展名
'*******************************************************************

Function GetExtend(filename)
    Dim tmp
    If filename>"" Then
        tmp = Mid(filename, instrrev(filename, ".") + 1, Len(filename) - instrrev(filename, "."))
        tmp = LCase(tmp)
        If InStr(1, tmp, "asp")>0 or InStr(1, tmp, "php")>0 or InStr(1, tmp, "php3")>0 or InStr(1, tmp, "aspx")>0 Then
            getextend = "txt"
        Else
            getextend = tmp
        End If
    Else
        getextend = ""
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：CheckIn
' * 描述：檢測(cè)參數(shù)是否有SQL危險(xiǎn)字符
' * 參數(shù)：str要檢測(cè)的數(shù)據(jù)
' * 返回：FALSE：安全 TRUE：不安全
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function CheckIn(Str)
    If InStr(1, Str, Chr(39))>0 or InStr(1, Str, Chr(34))>0 or InStr(1, Str, Chr(59))>0 Then
        CheckIn = True
    Else
        CheckIn = False
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLEncode
' * 描述：過(guò)濾HTML代碼
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function HTMLEncode(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, Chr(10)  Chr(10), "/P>P> ")
        fString = Replace(fString, Chr(10), "BR> ")
        HTMLEncode = fString
    End If
End Function

' *----------------------------------------------------------------------------
' * 函數(shù)：HTMLcode
' * 描述：過(guò)濾表單字符
' * 參數(shù)：--
' * 返回：--
' * 作者：
' * 日期：
' *----------------------------------------------------------------------------

Function HTMLcode(fString)
    If Not IsNull(fString) Then
        fString = Replace(fString, Chr(13), "")
        fString = Replace(fString, Chr(10)  Chr(10), "/P>P>")
        fString = Replace(fString, Chr(34), "")
        fString = Replace(fString, Chr(10), "BR>")
        HTMLcode = fString
    End If
End Function
%>
11.ACCESS數(shù)據(jù)庫(kù)連接:
%
Option Explicit
Dim startime, endtime, conn, connstr, db
startime = Timer()
'更改數(shù)據(jù)庫(kù)名字
db = "data/dvBBS5.mdb"
Set conn = Server.CreateObject("ADODB.Connection")
connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="  Server.MapPath(db)
'如果你的服務(wù)器采用較老版本Access驅(qū)動(dòng)，請(qǐng)用下面連接方法
'connstr="driver={Microsoft Access Driver (*.mdb)};dbq="  Server.MapPath(db)
conn.Open connstr

Function CloseDatabase
    Conn.Close
    Set conn = Nothing
End Function
%>
12.SQL數(shù)據(jù)庫(kù)連接:
%
Option Explicit
Dim startime, endtime, conn, connstr, db
startime = Timer()
connstr = "driver={SQL Server};server=HUDENQ-N11T33NB;uid=sa;pwd=xsfeihu;database=dvbbs"
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open connstr

Function CloseDatabase
    Conn.Close
    Set conn = Nothing
End Function
%>
13.用鍵盤(pán)打開(kāi)網(wǎng)頁(yè)代碼:
script language="javascript">
function ctlent(eventobject)
{
if((event.ctrlKey  window.event.keyCode==13)||(event.altKey  window.event.keyCode==83))
{
window.open('網(wǎng)址','','')
}
}
/script>　
這里是Ctrl+Enter和Alt+S的代碼自己查下鍵盤(pán)的ASCII碼再換就行
14.讓層不被控件復(fù)蓋代碼:
div z-Index:2>object ***>/object>/div> ＃前面
div z-Index:1>object ***>/object>/div> ＃后面
div id="Layer2" style="position:absolute; top:40;width:400px; height:95px;z-index:2">table height=100% width=100% bgcolor="#ff0000">tr>td height=100% width=100%>/td>/tr>/table>iframe width=0 height=0>/iframe>/div>
div id="Layer1" style="position:absolute; top:50;width:200px; height:115px;z-index:1">iframe height=100% width=100%>/iframe>/div>
15.動(dòng)網(wǎng)FLASH廣告代碼:
object classid="clsid27CDB6E-AE6D-11cf-96B8-444553540000" codebase="http://download.macromedia.com/pub/shockwave/cabs/flash/swflash.cab#version=5,0,0,0" width="468" height="60">param name=movie value="images/yj16d.swf">param name=quality value=high>embed src="images/dvbanner.swf" quality=high pluginspage="http://www.macromedia.com/shockwave/download/index.cgi?P1_Prod_Version=ShockwaveFlash";;; type="application/x-shockwave-flash" width="468" height="60">/embed>/object>
16.VBS彈出窗口小代碼:
script language=vbscript>
msgbox"你還沒(méi)有注冊(cè)或登陸論壇","0","精品論壇"
location.href = "login.asp"
/script>
16.使用FSO修改文件特定內(nèi)容的函數(shù)
%
Function FSOchange(filename, Target, String)
    Dim objFSO, objCountFile, FiletempData
    Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
    Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename), 1, True)
    FiletempData = objCountFile.ReadAll
    objCountFile.Close
    FiletempData = Replace(FiletempData, Target, String)
    Set objCountFile = objFSO.CreateTextFile(Server.MapPath(filename), True)
    objCountFile.Write FiletempData
    objCountFile.Close
    Set objCountFile = Nothing
    Set objFSO = Nothing
End Function
%>
17.使用FSO讀取文件內(nèi)容的函數(shù)
%
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
%>
18.使用FSO讀取文件某一行的函數(shù)
%
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
%>
19.使用FSO寫(xiě)文件某一行的函數(shù)
%
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
%>
20.使用FSO添加文件新行的函數(shù)
%
Function FSOappline(filename, Linecontent)
    Dim fso, f
    Set fso = server.CreateObject("scripting.filesystemobject")
    If Not fso.FileExists(server.mappath(filename)) Then Exit Function
    Set f = fso.OpenTextFile(server.mappath(filename), 8, 1)
    f.Write Chr(13)Chr(10)Linecontent
    f.Close
    Set f = Nothing
End Function
%>
21.讀文件最后一行的函數(shù)
%
Function FSOlastline(filename)
    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))
        FSOlastline = temparray(UBound(temparray))
    End If
End Function
%>
利用FSO取得BMP，JPG，PNG，GIF文件信息(大小，寬、高等)
%
'::: BMP, GIF, JPG and PNG :::　
'::: This function gets a specified number of bytes from any :::
'::: file, starting at the offset (base 1) :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: offset => Offset at which to start reading :::
'::: bytes => How many bytes to read :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function GetBytes(flnm, offset, bytes)
    Dim objFSO
    Dim objFTemp
    Dim objTextStream
    Dim lngSize
    On Error Resume Next
    Set objFSO = CreateObject("Scripting.FileSystemObject")　
    ' First, we get the filesize
    Set objFTemp = objFSO.GetFile(flnm)
    lngSize = objFTemp.Size
    Set objFTemp = Nothing
    fsoForReading = 1
    Set objTextStream = objFSO.OpenTextFile(flnm, fsoForReading)
    If offset > 0 Then
        strBuff = objTextStream.Read(offset - 1)
    End If
    If bytes = -1 Then ' Get All!
        GetBytes = objTextStream.Read(lngSize) 'ReadAll
    Else
        GetBytes = objTextStream.Read(bytes)
    End If
    objTextStream.Close
    Set objTextStream = Nothing
    Set objFSO = Nothing
End Function　

':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: Functions to convert two bytes to a numeric value (long) :::
'::: (both little-endian and big-endian) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function lngConvert(strTemp)
    lngConvert = CLng(Asc(Left(strTemp, 1)) + ((Asc(Right(strTemp, 1)) * 256)))
End Function

Function lngConvert2(strTemp)
    lngConvert2 = CLng(Asc(Right(strTemp, 1)) + ((Asc(Left(strTemp, 1)) * 256)))
End Function　

':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: :::
'::: This function does most of the real work. It will attempt :::
'::: to read any file, regardless of the extension, and will :::
'::: identify if it is a graphical image. :::
'::: :::
'::: Passed: :::
'::: flnm => Filespec of file to read :::
'::: width => width of image :::
'::: height => height of image :::
'::: depth => color depth (in number of colors) :::
'::: strImageType=> type of image (e.g. GIF, BMP, etc.) :::
'::: :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

Function gfxSpex(flnm, Width, height, depth, strImageType)
    Dim strPNG
    Dim strGIF
    Dim strBMP
    Dim strType
    strType = ""
    strImageType = "(unknown)"
    gfxSpex = False
    strPNG = Chr(137)  Chr(80)  Chr(78)
    strGIF = "GIF"
    strBMP = Chr(66)  Chr(77)
    strType = GetBytes(flnm, 0, 3)
    If strType = strGIF Then ' is GIF
        strImageType = "GIF"
        Width = lngConvert(GetBytes(flnm, 7, 2))
        Height = lngConvert(GetBytes(flnm, 9, 2))
        Depth = 2 ^ ((Asc(GetBytes(flnm, 11, 1)) And 7) + 1)
        gfxSpex = True
    ElseIf Left(strType, 2) = strBMP Then ' is BMP
        strImageType = "BMP"
        Width = lngConvert(GetBytes(flnm, 19, 2))
        Height = lngConvert(GetBytes(flnm, 23, 2))
        Depth = 2 ^ (Asc(GetBytes(flnm, 29, 1)))
        gfxSpex = True
    ElseIf strType = strPNG Then ' Is PNG
        strImageType = "PNG"
        Width = lngConvert2(GetBytes(flnm, 19, 2))
        Height = lngConvert2(GetBytes(flnm, 23, 2))
        Depth = getBytes(flnm, 25, 2)
        Select Case Asc(Right(Depth, 1))
            Case 0
                Depth = 2 ^ (Asc(Left(Depth, 1)))
                gfxSpex = True
            Case 2
                Depth = 2 ^ (Asc(Left(Depth, 1)) * 3)
                gfxSpex = True
            Case 3
                Depth = 2 ^ (Asc(Left(Depth, 1))) '8
                gfxSpex = True
            Case 4
                Depth = 2 ^ (Asc(Left(Depth, 1)) * 2)
                gfxSpex = True
            Case 6
                Depth = 2 ^ (Asc(Left(Depth, 1)) * 4)
                gfxSpex = True
            Case Else
                Depth = -1
        End Select　
    Else
        strBuff = GetBytes(flnm, 0, -1) ' Get all bytes from file
        lngSize = Len(strBuff)
        flgFound = 0
        strTarget = Chr(255)  Chr(216)  Chr(255)
        flgFound = InStr(strBuff, strTarget)
        If flgFound = 0 Then
            Exit Function
        End If
        strImageType = "JPG"
        lngPos = flgFound + 2
        ExitLoop = False
        Do While ExitLoop = False And lngPos  lngSize　
            Do While Asc(Mid(strBuff, lngPos, 1)) = 255 And lngPos  lngSize
                lngPos = lngPos + 1
            Loop
            If Asc(Mid(strBuff, lngPos, 1))  192 or Asc(Mid(strBuff, lngPos, 1)) > 195 Then
                lngMarkerSize = lngConvert2(Mid(strBuff, lngPos + 1, 2))
                lngPos = lngPos + lngMarkerSize + 1
            Else
                ExitLoop = True
            End If
        Loop
        '
        If ExitLoop = False Then
            Width = -1
            Height = -1
            Depth = -1
        Else
            Height = lngConvert2(Mid(strBuff, lngPos + 4, 2))
            Width = lngConvert2(Mid(strBuff, lngPos + 6, 2))
            Depth = 2 ^ (Asc(Mid(strBuff, lngPos + 8, 1)) * 8)
            gfxSpex = True
        End If　
    End If
End Function　

':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
'::: Test Harness :::
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::　
' To test, we'll just try to show all files with a .GIF extension in the root of C:
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objF = objFSO.GetFolder("c:\")
Set objFC = objF.Files
response.Write "table border=""0"" cellpadding=""5"">"
For Each f1 in objFC
    If InStr(UCase(f1.Name), ".GIF") Then
        response.Write "tr>td>"  f1.Name  "/td>td>"  f1.DateCreated  "/td>td>"  f1.Size  "/td>td>"
        If gfxSpex(f1.Path, w, h, c, strType) = True Then
            response.Write w  " x "  h  " "  c  " colors"
        Else
            response.Write " "
        End If
        response.Write "/td>/tr>"
    End If
Next
response.Write "/table>"
Set objFC = Nothing
Set objF = Nothing
Set objFSO = Nothing　
%>
24.點(diǎn)擊返回上頁(yè)代碼:
form>
p>input TYPE="button" value="返回上一步" onCLICK="history.back(-1)">/p>
/form>
24.點(diǎn)擊刷新代碼:
form>
p>input TYPE="button" value="刷新按鈕一" onCLICK="ReloadButton()">/p>
/form>
script language="javascript">!--
function ReloadButton(){location.href="allbutton.htm";}
// -->/script>　
24.點(diǎn)擊刷新代碼2:
form>
p>input TYPE="button" value="刷新按鈕二" onClick="history.go(0)"> /p>
/form>　
form>
p>input TYPE="button" value="打開(kāi)一個(gè)網(wǎng)站" onCLICK="HomeButton()">/p>
/form>
script language="javascript">!--
function HomeButton(){location.;;;}
// -->/script>　
25.彈出警告框代碼:
form>
p>input TYPE="button" value="彈出警告框" onCLICK="AlertButton()">/p>
/form>
script language="javascript">!--
function AlertButton(){window.alert("要多多光臨呀！");}
// -->/script>　
26.狀態(tài)欄信息
form>
p>input TYPE="button" value="狀態(tài)欄信息" onCLICK="StatusButton()">/p>
/form>
script language="javascript">!--
function StatusButton(){window.status="要多多光臨呀！";}
// -->/script>　
27.背景色變換
form>
p>input TYPE="button" value="背景色變換" onClick="BgButton()">/p>
/form>
script>function BgButton(){
if (document.bgColor=='#00ffff')
{document.bgColor='#ffffff';}
else{document.bgColor='#00ffff';}
}
/script>　
28.點(diǎn)擊打開(kāi)新窗口
form>
p>input TYPE="button" value="打開(kāi)新窗口" onCLICK="NewWindow()">/p>
/form>
script language="javascript">!--
function NewWindow(){window.open("http://www.mcmx.com";;,"","height=240,width=340,status=no,location=no,toolbar=no,directories=no,menubar=no");}
// -->/script>/body>
29.分頁(yè)代碼:
%''本程序文件名為：Pages.asp%>
%''包含ADO常量表文件adovbs.inc，可從"\Program Files\Common Files\System\ADO"目錄下拷貝%>
!--#Include File="adovbs.inc"-->
%''＊建立數(shù)據(jù)庫(kù)連接，這里是Oracle8.05數(shù)據(jù)庫(kù)
Set conn = Server.CreateObject("ADODB.Connection")
conn.Open "Provider=msdaora.1;Data Source=YourSrcName;User ID=YourUserID;Password=YourPassword;" 　
Set rs = Server.CreateObject("ADODB.Recordset") ''創(chuàng)建Recordset對(duì)象
rs.CursorLocation = adUseClient ''設(shè)定記錄集指針屬性
''＊設(shè)定一頁(yè)內(nèi)的記錄總數(shù)，可根據(jù)需要進(jìn)行調(diào)整
rs.PageSize = 10 　
''＊設(shè)置查詢語(yǔ)句
StrSQL = "Select ID,姓名,住址,電話 from 通訊錄 order By ID"
rs.Open StrSQL, conn, adOpenStatic, adLockReadOnly, adCmdText
%>
HTML>
HEAD>
title>分頁(yè)示例/title>
script language=javascript>
//點(diǎn)擊"[第一頁(yè)]"時(shí)響應(yīng)：
function PageFirst()
{
document.MyForm.CurrentPage.selectedIndex=0;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[上一頁(yè)]"時(shí)響應(yīng)：
function PagePrior()
{
document.MyForm.CurrentPage.selectedIndex--;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[下一頁(yè)]"時(shí)響應(yīng)：
function PageNext()
{
document.MyForm.CurrentPage.selectedIndex++;
document.MyForm.CurrentPage.onchange();
}
//點(diǎn)擊"[最后一頁(yè)]"時(shí)響應(yīng)：
function PageLast()
{
document.MyForm.CurrentPage.selectedIndex=document.MyForm.CurrentPage.length-1;
document.MyForm.CurrentPage.onchange();
}
//選擇"第？頁(yè)"時(shí)響應(yīng)：
function PageCurrent()
{ //Pages.asp是本程序的文件名
document.MyForm.action='Pages.asp?Page='+(document.MyForm.CurrentPage.selectedIndex+1)
document.MyForm.submit();
}
/Script>
/HEAD>
BODY bgcolor="#ffffcc" link="#008000" vlink="#008000" alink="#FF0000"">　
%
If rs.EOF Then
    Response.Write("font size=2 color=#000080>[數(shù)據(jù)庫(kù)中沒(méi)有記錄！]/font>")
Else
    ''指定當(dāng)前頁(yè)碼
    If Request("CurrentPage") = "" Then
        rs.AbsolutePage = 1
    Else
        rs.AbsolutePage = CLng(Request("CurrentPage"))
    End If 　
    ''創(chuàng)建表單MyForm,方法為Get
    Response.Write("form method=Get name=MyForm>")
    Response.Write("p align=center>font size=2 color=#008000>")
    ''設(shè)置翻頁(yè)超鏈接
    If rs.PageCount = 1 Then
        Response.Write("[第一頁(yè)] [上一頁(yè)] [下一頁(yè)] [最后一頁(yè)] ")
    Else
        If rs.AbsolutePage = 1 Then
            Response.Write("[第一頁(yè)] [上一頁(yè)] ")
            Response.Write("[a href=java script:PageNext()>下一頁(yè)/a>] ")
            Response.Write("[a href=java script:PageLast()>最后一頁(yè)/a>] ")
        Else
            If rs.AbsolutePage = rs.PageCount Then
                Response.Write("[a href=java script:PageFirst()>第一頁(yè)/a>] ")
                Response.Write("[a href=java script:PagePrior()>上一頁(yè)/a>] ")
                Response.Write("[下一頁(yè)] [最后一頁(yè)] ")
            Else
                Response.Write("[a href=java script:PageFirst()>第一頁(yè)/a>] ")
                Response.Write("[a href=java script:PagePrior()>上一頁(yè)/a>] ")
                Response.Write("[a href=java script:PageNext()>下一頁(yè)/a>] ")
                Response.Write("[a href=java script:PageLast()>最后一頁(yè)/a>] ")
            End If
        End If
    End If　
    ''創(chuàng)建下拉列表框，用于選擇瀏覽頁(yè)碼
    Response.Write("第select size=1 name=CurrentPage onchange=PageCurrent()>")
    For i = 1 To rs.PageCount
        If rs.AbsolutePage = i Then
            Response.Write("option selected>"i"/option>") ''當(dāng)前頁(yè)碼
        Else
            Response.Write("option>"i"/option>")
        End If
    Next
    Response.Write("/select>頁(yè)/共"rs.PageCount"頁(yè) 共"rs.RecordCount"條記錄/font>p>")
    Response.Write("/form>")　
    ''創(chuàng)建表格，用于顯示
    Response.Write("table align=center cellspacing=1 cellpadding=1 border=1")
    Response.Write(" bordercolor=#99CCFF bordercolordark=#b0e0e6 bordercolorlight=#000066>")　
    Response.Write("tr bgcolor=#ccccff bordercolor=#000066>") 　
    Set Columns = rs.Fields 　
    ''顯示表頭
    For i = 0 To Columns.Count -1
        Response.Write("td align=center width=200 height=13>")
        Response.Write("font size=2>b>"Columns(i).Name"/b>/font>/td>")
    Next
    Response.Write("/tr>")
    ''顯示內(nèi)容
    For i = 1 To rs.PageSize
        Response.Write("tr bgcolor=#99ccff bordercolor=#000066>")
        For j = 0 To Columns.Count -1
            Response.Write("td>font size=2>"Columns(j)"/font>/td>")
        Next
        Response.Write("/tr>")　
        rs.movenext
        If rs.EOF Then Exit For
        Next　
        Response.Write("/table>") 　
    End If
%>
/BODY>
/HTML>
%
Rem - - - 表單提示函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...

Function Check_submit(Str, restr)
    If Str = "" Then
        response.Write "script>"
        response.Write "alert(‘'"restr"‘');"
        response.Write "history.go(-1)"
        response.Write "/script>"
        response.End
    Else
        Check_submit = Str
    End If
End Function

CODE Copy ...

Function Alert_submit(Str)
    response.Write "script>"
    response.Write "alert(‘'"Str"‘');"
    ‘'response.Write "location.reload();"
    response.Write "/script>"
End Function

CODE Copy ...

Function localhost_submit(Str, urls)
    response.Write "script>"
    If Str>"" Then
        response.Write "alert(‘'"Str"‘');"
    End If
    response.Write "location=‘'"urls"‘';"
    response.Write "/script>"
End Function

Rem - - - 生成自定義位隨機(jī)數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...

Function makerndid(byVal maxLen)
    Dim strNewPass
    Dim whatsNext, upper, lower, intCounter
    Randomize
    For intCounter = 1 To maxLen
        whatsNext = Int(2 * Rnd)
        If whatsNext = 0 Then
            upper = 80
            lower = 70
        Else
            upper = 48
            lower = 39
        End If
        strNewPass = strNewPass  Chr(Int((upper - lower + 1) * Rnd + upper))
    Next
    makerndid = strNewPass
End Function

Rem - - - 生成四位隨機(jī)數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...

Function get_rand()
    Dim num1
    Dim rndnum
    Randomize
    Do While Len(rndnum)4
        num1 = CStr(Chr((57 -48) * Rnd + 48))
        rndnum = rndnumnum1
    Loop
    get_rand = rndnum
End Function

Rem - - - 判斷數(shù)據(jù)是否整型 Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...

Function IsInteger(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

Rem - - - 數(shù)據(jù)庫(kù)鏈接函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...

Function OpenCONN
    Set conn = Server.CreateObject("ADODB.Connection")
    connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="  Server.MapPath(DB_login)
    conn.Open connstr
End Function

Rem - - - 中文字符轉(zhuǎn)Uncode代碼函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
CODE Copy ...

Function URLEncoding(vstrIn)
    strReturn = ""
    For i = 1 To Len(vstrIn)
        ThisChr = Mid(vStrIn, i, 1)
        If Abs(Asc(ThisChr))  HFF Then
            strReturn = strReturn  ThisChr
        Else
            innerCode = Asc(ThisChr)
            If innerCode  0 Then
                innerCode = innerCode + H10000
            End If
            Hight8 = (innerCode And HFF00) \&;HFF
            Low8 = innerCode And HFF
            strReturn = strReturn  "%"  Hex(Hight8)  "%"  Hex(Low8)
        End If
    Next
    URLEncoding = strReturn
End Function

Rem - - - Html過(guò)濾函數(shù) Being - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Function Htmlout(Str)
CODE Copy ...
Dim result
Dim l
If IsNull(Str) Then
    Htmlout = ""
    Exit Function
End If
l = Len(Str)
result = ""
Dim i
For i = 1 To l
    Select Case Mid(Str, i, 1)
        Case ""
            result = result + "lt;"
        Case ">"
            result = result + "gt;"
        Case Chr(13)
            If session("admin_system") = "" Then
                result = result + "br>"
            End If
        Case Chr(34)
            result = result + "quot;"
        Case ""
            result = result + ""
        Case Chr(32)
            ‘'result = result + "nbsp;"
            If i + 1= l And i -1>0 Then
                If Mid(Str, i + 1, 1) = Chr(32) or Mid(Str, i + 1, 1) = Chr(9) or Mid(Str, i -1, 1) = Chr(32) or Mid(Str, i -1, 1) = Chr(9) Then
                    result = result + "nbsp;"
                Else
                    result = result + " "
                End If
            Else
                result = result + "nbsp;"
            End If
        Case Chr(9)
            result = result + " "
        Case Else
            result = result + Mid(Str, i, 1)
    End Select
Next
Htmlout = result
End Function

Rem - - - textarea顯示用 - - -
CODE Copy ...

Function htmlencode1(fString)
    If fString>"" And Not IsNull(fString) Then
        fString = Replace(fString, "gt;", ">")
        fString = Replace(fString, "lt;", "")
        fString = Replace(fString, "nbsp;", Chr(32))
        fString = Replace(fString, "/p>p>", Chr(10)  Chr(10))
        fString = Replace(fString, "br>", Chr(10))
        htmlencode1 = fString
    Else
        htmlencode1 = ""
    End If
End Function

Rem - - - 頁(yè)面顯示用 - - -
CODE Copy ...

Function htmlencode2(fString)
    If fString>"" And Not IsNull(fString) Then
        fString = Replace(fString, ">", "gt;")
        fString = Replace(fString, "", "lt;")
        fString = Replace(fString, Chr(32), "nbsp;")
        fString = Replace(fString, Chr(10)  Chr(10), "/p>p>")
        fString = Replace(fString, Chr(10), "br>")
        htmlencode2 = fString
    Else
        htmlencode2 = ""
    End If
End Function

Rem - - - 取出指定字符串前后的字符串方法 - - -
CODE Copy ...

Function GetStrs(str1, CharFlag, Dflag)
    Dim tmpstr
    If Dflag = 0 Then‘'取左
    pos1 = InStr(str1, charFlag)
    If pos1= 20 Then
        tmpstr = Left(str1, pos1 -1)
    Else
        tmpstr = Mid(str1, pos1 -20, 20)
    End If
Else ‘'取右
    pos1 = InStr(str1, charFlag) + Len(charFlag)
    If Len(str1) - pos1= 20 Then
        tmpstr = Right(str1, Len(str1) - pos1)
    Else
        tmpstr = Mid(str1, pos1 + 1, 20)
    End If
End If
GetStrs = tmpstr
End Function

Rem - - - 取出文件名 - - -
CODE Copy ...

Function GetFileName(Str)
    pos = InStr(Str, ".")
    If Str>"" Then
        Str = Mid(Str, pos, Len(Str))
    End If
    GetFileName = Str
End Function

Rem - - - 取到瀏覽器版本轉(zhuǎn)換字符串 - - -
CODE Copy ...

Function browser()
    Dim text
    text = Request.ServerVariables("HTTP_USER_AGENT")
    If InStr(text, "MSIE 5.5")>0 Then
        browser = "IE 5.5"
    ElseIf InStr(text, "MSIE 6.0")>0 Then
        browser = "IE 6.0"
    ElseIf InStr(text, "MSIE 5.01")>0 Then
        browser = "IE 5.01"
    ElseIf InStr(text, "MSIE 5.0")>0 Then
        browser = "IE 5.00"
    ElseIf InStr(text, "MSIE 4.0")>0 Then
        browser = "IE 4.01"
    Else
        browser = "未知"
    End If
End Function

Rem - - - 取到系統(tǒng)腳本轉(zhuǎn)換字符串 - - -
CODE Copy ...

Function System(text)
    If InStr(text, "NT 5.1")>0 Then
        System = System + "Windows XP"
    ElseIf InStr(text, "NT 5")>0 Then
        System = System + "Windows 2000"
    ElseIf InStr(text, "NT 4")>0 Then
        System = System + "Windows NT4"
    ElseIf InStr(text, "4.9")>0 Then
        System = System + "Windows ME"
    ElseIf InStr(text, "98")>0 Then
        System = System + "Windows 98"
    ElseIf InStr(text, "95")>0 Then
        System = System + "Windows 95"
    Else
        System = System + "未知"
    End If
End Function

Rem - - - = 刪除文件 - - -
CODE Copy ...

Function delfile(filepath)
    imangepath = Trim(filepath)
    Path = server.MapPath(imangepath)
    Set fs = server.CreateObject("Scripting.FileSystemObject")
    If FS.FileExists(Path) Then
        FS.DeleteFile(Path)
    End If
    Set fs = Nothing
End Function

Rem - - - 得到真實(shí)的客戶端IP - - -
CODE Copy ...

Public Function GetClientIP()
    Dim uIpAddr
    ‘' 本函數(shù)參考webcn.Net / AspHouse 文獻(xiàn)取真實(shí)的客戶IP>
    uIpAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
    If uIpAddr = "" Then uIpAddr = Request.ServerVariables("REMOTE_ADDR")
    GetClientIP = uIpAddr
    uIpAddr = ""
End Function

%>

數(shù)據(jù)庫(kù)查詢中的特殊字符的問(wèn)題
在進(jìn)行數(shù)據(jù)庫(kù)的查詢時(shí)，會(huì)經(jīng)常遇到這樣的情況：
　　例如想在一個(gè)用戶數(shù)據(jù)庫(kù)中查詢他的用戶名和他的密碼，但恰好該用戶使用的名字和密碼中有特殊的字符，例如單引號(hào)，“|”號(hào)，雙引號(hào)或者連字符“”。
　　例如他的名字是1"test，密碼是A|900
　　這時(shí)當(dāng)你執(zhí)行以下的查詢語(yǔ)句時(shí)，肯定會(huì)報(bào)錯(cuò)：
SQL = "Select * FROM SecurityLevel Where UID=""  UserID  """
SQL = SQL  " AND PWD=""  Password  """
　　因?yàn)槟愕腟QL將會(huì)是這樣：
Select * FROM SecurityLevel Where UID="1"test" AND PWD="A|900"
　　在SQL中，"|"為分割字段用的，顯然會(huì)出錯(cuò)了?，F(xiàn)在提供下面的幾個(gè)函數(shù) 專(zhuān)門(mén)用來(lái)處理這些頭疼的東西：
Quoted from Unkown:
%
Function ReplaceStr (TextIn, ByVal SearchStr As String, _
                     ByVal Replacement As String, _
                     ByVal CompMode As Integer)

    　Dim WorkText As String, Pointer As Integer
    　If IsNull(TextIn) Then
    　　ReplaceStr = Null
    　Else
    　　WorkText = TextIn
    　　Pointer = InStr(1, WorkText, SearchStr, CompMode)
    　　Do While Pointer > 0
    　　　WorkText = Left(WorkText, Pointer - 1)  Replacement  _
                     　　　Mid(WorkText, Pointer + Len(SearchStr))
    　　　Pointer = InStr(Pointer + Len(Replacement), WorkText, SearchStr, CompMode)
    　　Loop
    　　ReplaceStr = WorkText
    　End If
End Function

Function SQLFixup(TextIn)
    　SQLFixup = ReplaceStr(TextIn, """, """", 0)
End Function

Function JetSQLFixup(TextIn)
    　Dim Temp
    　Temp = ReplaceStr(TextIn, """, """", 0)
    　JetSQLFixup = ReplaceStr(Temp, "|", ""  Chr(124)  "", 0)
End Function

Function FindFirstFixup(TextIn)
    　Dim Temp
    　Temp = ReplaceStr(TextIn, """, ""  chr(39)  "", 0)
    　FindFirstFixup = ReplaceStr(Temp, "|", ""  Chr(124)  "", 0)
End Function

Rem 借助RecordSet將二進(jìn)制流轉(zhuǎn)化成文本
Quoted from Unkown:

Function BinaryToString(biData, Size)
    Const adLongVarChar = 201
    Set RS = CreateObject("ADODB.Recordset")
    RS.Fields.Append "mBinary", adLongVarChar, Size
    RS.Open
    RS.AddNew
    RS("mBinary").AppendChunk(biData)
    RS.Update
    BinaryToString = RS("mBinary").Value
    RS.Close
End Function

%>
%
'定義超全局變量
Dim URLSelf, URISelf
URISelf = Request.ServerVariables("SCRIPT_NAME")
If Request.QueryString = "" Then
    URLSelf = URISelf
Else
    URLSelf = URISelf  "?"  Request.QueryString
End If
Response.CharSet = "GB2312"
Response.Buffer = True
Response.Expires = -1

'===================================================================================
' 函數(shù)原型：GotoURL (URL)
'功能：轉(zhuǎn)到指定的URL
'參數(shù)：URL 要跳轉(zhuǎn)的URL
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GotoURL(URL)
    Response.Write "script language=""JavaScript"">location.href='"  URL  "';/script>"
End Function

'===================================================================================
' 函數(shù)原型：MessageBox (Msg)
'功能：顯示消息框
'參數(shù)：要顯示的消息
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function MessageBox(msg)
    msg = Replace(msg, "\", "\\")
    msg = Replace(msg, "'", "\'")
    msg = Replace(msg, """", "\""")
    msg = Replace(msg, vbCrLf, "\n")
    msg = Replace(msg, vbCr, "")
    msg = Replace(msg, vbLf, "")
    Response.Write "script language=""JavaScript"">alert('"  msg  "');/script>"
End Function

'===================================================================================
' 函數(shù)原型：ReturnValue (bolValue)
'功能：設(shè)置Window對(duì)象的返回值：只能是布爾值
'參數(shù)：返回值
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function ReturnValue(bolValue)
    If bolValue Then
        Response.Write "script language=""JavaScript"">window.returnValue=true;/script>"
    Else
        Response.Write "script language=""JavaScript"">window.returnValue=false;/script>"
    End If
End Function

'===================================================================================
' 函數(shù)原型：GoBack (URL)
'功能：后退
'參數(shù)：無(wú)
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GoBack()
    Response.Write "script language=""JavaScript"">history.go(-1);/script>"
End Function

'===================================================================================
' 函數(shù)原型：CloseWindow ()
'功能：關(guān)閉窗口
'參數(shù)：無(wú)
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function CloseWindow()
    Response.Write "script language=""JavaScript"">window.opener=null;window.close();/script>"
End Function

'===================================================================================
' 函數(shù)原型：RefreshParent ()
'功能：刷新父框架
'參數(shù)：無(wú)
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function RefreshParent()
    Response.Write "script language=""JavaScript"">if(parent!=self) parent.location.reload();/script>"
End Function

'===================================================================================
' 函數(shù)原型：RefreshTop ()
'功能：刷新頂級(jí)框架
'參數(shù)：無(wú)
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function RefreshTop()
    Response.Write "script language=""JavaScript"">if(top!=self) top.location.reload();/script>"
End Function

'===================================================================================
' 函數(shù)原型：GenPassword (intLen,PassMask)
'功能：生成隨機(jī)密碼
'參數(shù)：intLen新密碼長(zhǎng)度
'PassMask生成密碼的掩碼默認(rèn)為空
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GenPassword(intLen, PassMask)
    Dim iCnt, PosTemp
    Randomize
    If PassMask = "" Then
        PassMask = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789abcdefghijklmnopqrstuvwxyz"
    End If
    For iCnt = 1 To intLen
        PosTemp = Fix(Rnd(1) * (Len(PassMask))) + 1
        GenPassword = GenPassword  Mid(PassMask, PosTemp, 1)
    Next
End Function

'===================================================================================
' 函數(shù)原型：GenSerialString ()
'功能：生成序列號(hào)
'參數(shù)：無(wú)
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GenSerialString()
    GenSerialString = Year(Now())
    If Month(Now())10 Then
        GenSerialString = GenSerialString  "0"
    End If
    GenSerialString = GenSerialString  Month(Now())
    If Day(Now())10 Then
        GenSerialString = GenSerialString  "0"
    End If
    GenSerialString = GenSerialString  Day(Now())
    If Hour(Now())10 Then
        GenSerialString = GenSerialString  "0"
    End If
    GenSerialString = GenSerialString  Hour(Now())
    If Minute(Now())10 Then
        GenSerialString = GenSerialString  "0"
    End If
    GenSerialString = GenSerialString  Minute(Now())
    If Second(Now())10 Then
        GenSerialString = GenSerialString  "0"
    End If
    GenSerialString = GenSerialString  Second(Now())
    GenSerialString = GenSerialString  GenPassword(6, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")
End Function

'===================================================================================
' 函數(shù)原型：ChangePage(URLTemplete,PageIndex)
'功能：根據(jù)URL模板生成新的頁(yè)面URL
'參數(shù)：URLTempleteURL模板
' PageIndex新的頁(yè)碼
'返回值：生成的URL
'涉及的表：無(wú)
'===================================================================================

Public Function ChangePage(URLTemplete, PageIndex)
    ChangePage = SetQueryString(URLTemplete, "PAGE", PageIndex)
End Function

'===================================================================================
' 函數(shù)原型：BuildPath(sPath)
'功能：根據(jù)指定的路徑創(chuàng)建目錄
'參數(shù)：sPathURL模板
'返回值：如果成功，返回空字符串，否則返回錯(cuò)誤信息和錯(cuò)誤位置
'涉及的表：無(wú)
'===================================================================================

Public Function BuildPath (sPath)
    Dim iCnt
    Dim Path
    Dim BasePath
    Path = Split(sPath, "/")
    If Left(sPath, 1) = "/" or Left(sPath, 1) = "\" Then
        BasePath = Server.MapPath("/")
    Else
        BasePath = Server.MapPath(".")
    End If
    Dim cPath, oFso
    cPath = BasePath
    BuildPath = ""
    Set oFso = Server.CreateObject("Scripting.FileSystemObject")
    For iCnt = LBound(Path) To UBound(Path)
        If Trim(Path(iCnt))>"" Then
            cPath = cPath  "\"  Trim(Path(iCnt))
            If Not oFso.FolderExists(cPath) Then
                On Error Resume Next
                oFso.CreateFolder cPath
                If Err.Number>0 Then
                    BuildPath = Err.Description  "["  cPath  "]"
                    Exit For
                End If
                On Error GoTo 0
            End If
        End If
    Next
    Set oFso = Nothing
End Function

'===================================================================================
' 函數(shù)原型：GetUserAgentInfo(ByRef vSoft,ByRef vOs)
'功能：獲取客戶端操作系統(tǒng)和瀏覽器信息
'參數(shù)：vSoft瀏覽器信息
'vOs操作系統(tǒng)信息
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GetUserAgentInfo(ByRef vSoft, ByRef vOs)
    Dim theSoft
    theSoft = Request.ServerVariables("HTTP_USER_AGENT")
    ' 瀏覽器
    If InStr(theSoft, "NetCaptor") Then
        vSoft = "NetCaptor"
    ElseIf InStr(theSoft, "MSIE 6") Then
        vSoft = "MSIE 6.0"
    ElseIf InStr(theSoft, "MSIE 5.5+") Then
        vSoft = "MSIE 5.5"
    ElseIf InStr(theSoft, "MSIE 5") Then
        vSoft = "MSIE 5.0"
    ElseIf InStr(theSoft, "MSIE 4") Then
        vSoft = "MSIE 4.0"
    ElseIf InStr(theSoft, "Netscape") Then
        vSoft = "Netscape"
    ElseIf InStr(theSoft, "Opera") Then
        vSoft = "Opera"
    Else
        vSoft = "Other"
    End If
    ' 操作系統(tǒng)
    If InStr(theSoft, "Windows NT 5.0") Then
        vOs = "Windows 2000"
    ElseIf InStr(theSoft, "Windows NT 5.1") Then
        vOs = "Windows XP"
    ElseIf InStr(theSoft, "Windows NT 5.2") Then
        vOs = "Windows 2003"
    ElseIf InStr(theSoft, "Windows NT") Then
        vOs = "Windows NT"
    ElseIf InStr(theSoft, "Windows 9") Then
        vOs = "Windows 9x"
    ElseIf InStr(theSoft, "unix") Then
        vOs = "Unix"
    ElseIf InStr(theSoft, "linux") Then
        vOs = "Linux"
    ElseIf InStr(theSoft, "SunOS") Then
        vOs = "SunOS"
    ElseIf InStr(theSoft, "BSD") Then
        vOs = "BSD"
    ElseIf InStr(theSoft, "Mac") Then
        vOs = "Mac"
    Else
        vOs = "Other"
    End If
End Function

'===================================================================================
' 函數(shù)原型：GetRegexpObject()
'功能：獲得一個(gè)正則表達(dá)式對(duì)象
'參數(shù)：無(wú)
'返回值：正則表達(dá)式對(duì)象
'涉及的表：無(wú)
'===================================================================================

Public Function GetRegExpObject(sPattern)
    Dim r
    Set r = New RegExp
    r.Global = True
    r.IgnoreCase = True
    r.MultiLine = True
    r.Pattern = sPattern
    Set GetRegexpObject = r
    Set r = Nothing
End Function

'===================================================================================
' 函數(shù)原型：RegExpTest(pattern,string)
'功能：正則表達(dá)式檢測(cè)
'參數(shù)：pattern模式字符串
'string待檢查的字符串
'返回值：是否匹配
'涉及的表：無(wú)
'===================================================================================

Public Function RegExpTest(p, s)
    Dim r
    Set r = GetRegExpObject(p)
    RegExpTest = r.Test(s)
    Set r = Nothing
End Function

'===================================================================================

' 函數(shù)原型：RegExpReplace(sSource,sPattern,sRep)
'功能：正則表達(dá)式替換
'參數(shù)：sSource要替換的源字符串
'sPattern模式字符串
'sRep要替換的目標(biāo)字符串
'返回值：替換后的字符串
'涉及的表：無(wú)
'===================================================================================

Public Function RegExpReplace(sSource, sPattern, sRep)
    Dim r
    Set r = GetRegExpTest(sPattern)
    RegExpReplace = r.Replace(sSource, sRep)
    Set r = Nothing
End Function

'===================================================================================
' 函數(shù)原型：CreateXMLParser()
'功能：創(chuàng)建一個(gè)盡可能高版本的XMLDOM
'參數(shù)：無(wú)
'返回值：IDOMDocument對(duì)象
'涉及的表：無(wú)
'===================================================================================

Public Function CreateXMLParser()
    On Error Resume Next
    Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.4.0")
    If Err.Number>0 Then
        Err.Clear
        Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.3.0")
        If Err.Number>0 Then
            Err.Clear
            Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument.2.6")
            If Err.Number>0 Then
                Err.Clear
                Set CreateXMLParser = Server.CreateObject("MSXML2.DOMDocument")
                If Err.Number>0 Then
                    Err.Clear
                    Set CreateXMLParser = Server.CreateObject("Microsoft.XMLDOM")
                    If Err.Number>0 Then
                        Err.Clear
                        Set CreateXMLParser = Nothing
                    Else
                        Exit Function
                    End If
                Else
                    Exit Function
                End If
            Else
                Exit Function
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If
    On Error GoTo 0
End Function

'===================================================================================
' 函數(shù)原型：CreateHTTPPoster()
'功能：創(chuàng)建一個(gè)盡可能高版本的XMLHTTP
'參數(shù)：ServerOrClient創(chuàng)建ServerXMLHTTP還是XMLHTTP
'返回值：IXMLHTTP對(duì)象
'涉及的表：無(wú)
'===================================================================================

Public Function CreateHTTPPoster(soc)
    Dim s
    If soc Then
        s = "ServerXMLHTTP"
    Else
        s = "XMLHTTP"
    End If
    On Error Resume Next
    Set CreateHTTPPoster = Server.CreateObject("MSXML2."  s  ".4.0")
    If Err.Number>0 Then
        Err.Clear
        Set CreateHTTPPoster = Server.CreateObject("MSXML2."  s  ".3.0")
        If Err.Number>0 Then
            Err.Clear
            Set CreateHTTPPoster = Server.CreateObject("MSXML2."  s)
            If Err.Number>0 Then
                Set CreateHTTPPoster = Nothing
            Else
                Exit Function
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If
    On Error GoTo 0
End Function

'===================================================================================
' 函數(shù)原型：XMLThrowError (errCode,errReason)
'功能：拋出一個(gè)XML錯(cuò)誤消息
'參數(shù)：errCode錯(cuò)誤編碼
'errReason錯(cuò)誤原因
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Sub XMLThrowError (errCode, errReason)
    Response.Clear
    Response.ContentType = "text/xml"
    Response.Write"?xml version=""1.0"" encoding=""gb2312"" standalone=""yes"" ?>"  vbCrLf  _
        "ERROR CODE="""  errCode  """ REASON="""  errReason  """ />"  vbCrLf
    Response.Flush
    Response.End
End Sub

'===================================================================================
' 函數(shù)原型：GetXMLNodeValue(ByRef xmlDom,sFilter,sDefValue)
'功能：從一個(gè)XML文檔中查找指定節(jié)點(diǎn)的值
'參數(shù)：xmlDomXML文檔
'sFilterXPATH定位字符串
'sDefValue默認(rèn)值
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GetXMLNodeValue(ByRef xmlDom, sFilter, sDefValue)
    Dim oNode
    Set oNode = xmlDom.selectSingleNode(sFilter)
    If TypeName(oNode) = "Nothing" or TypeName(oNode) = "Null" or TypeName(oNode) = "Empty" Then
        GetXMLNodeValue = sDefValue
        Set oNode = Nothing
    Else
        GetXMLNodeValue = Trim(oNode.Text)
        Set oNode = Nothing
    End If
End Function

'===================================================================================
' 函數(shù)原型：GetXMLNodeAttribute(ByRef xmlDom,sFilter,sName,sDefValue)
'功能：從一個(gè)XML文檔中查找指定節(jié)點(diǎn)的指定屬性
'參數(shù)：xmlDomXML文檔
'sFilterXPATH定位字符串
'sName要查詢的屬性名稱(chēng)
'sDefValue默認(rèn)值
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GetXMLNodeAttribute(ByRef xmlDom, sFilter, sName, sDefValue)
    Dim oNode
    Set oNode = xmlDom.selectSingleNode(sFilter)
    If TypeName(oNode) = "Nothing" or TypeName(oNode) = "Null" or TypeName(oNode) = "Empty" Then
        GetXMLNodeAttribute = sDefValue
        Set oNode = Nothing
    Else
        Dim pTemp
        Set pTemp = oNode.getAttribute(sName)
        If TypeName(pTemp) = "Nothing" or TypeName(pTemp) = "Null" or TypeName(pTemp) = "Empty" Then
            GetXMLNodeAttribute = sDefValue
            Set oNode = Nothing
            Set pTemp = Nothing
        Else
            GetXMLNodeAttribute = Trim(pTemp.Value)
            Set oNode = Nothing
            Set pTemp = Nothing
        End If
    End If
End Function

'===================================================================================
' 函數(shù)原型：GetQueryStringNumber (FieldName,defValue)
'功能：從QueryString獲取一個(gè)整數(shù)
'參數(shù)：FieldName參數(shù)名
'defValue默認(rèn)值
'返回值：無(wú)
'涉及的表：無(wú)
'===================================================================================

Public Function GetQueryStringNumber (FieldName, defValue)
    Dim r
    r = Request.QueryString(FieldName)
    If r = "" Then
        GetQueryStringNumber = defValue
        Exit Function
    Else
        If Not IsNumeric(r) Then
            GetQueryStringNumber = defValue
            Exit Function
        Else
            On Error Resume Next
            r = CDbl(r)
            If Err.Number>0 Then
                Err.Clear
                GetQueryStringNumber = defValue
                Exit Function
            Else
                GetQueryStringNumber = r
            End If
            On Error GoTo 0
        End If
    End If
End Function

'===================================================================================
' 函數(shù)原型：I(yíng)If (testExpr,value1,value2)
'功能：相當(dāng)于C/C++里面的 ?: 運(yùn)算符
'參數(shù)：testExprBoolean表達(dá)式
'value1testExpr=True 時(shí)的取值
'value2testExpr=False 時(shí)的取值
'返回值：如果testExpr為T(mén)rue返回value1否則返回value2
'涉及的表：無(wú)
'說(shuō)明：VBScript里沒(méi)有Iif函數(shù)
'===================================================================================

Public Function IIf(testExpr, value1, value2)
    If testExpr = True Then
        IIf = value1
    Else
        IIf = value2
    End If
End Function

'===================================================================================
' 函數(shù)原型：URLEncoding (v,f)
'功能：URL編碼函數(shù)
'參數(shù)：v中英文混合字符串
'f是否對(duì)ASCII字符編碼
'返回值：編碼后的ASC字符串
'涉及的表：無(wú)
'===================================================================================

Public Function URLEncoding(v, f)
    Dim s, t, i, j, h, l, x
    s = ""
    x = Len(v)
    For i = 1 To x
        t = Mid(v, i, 1)
        j = Asc(t)
        If j> 0 Then
            If f Then
                s = s  "%"  Right("00"  Hex(Asc(t)), 2)
            Else
                s = s  t
            End If
        Else
            If j  0 Then j = j + H10000
            h = (j And HFF00) \&;HFF
            l = j And HFF
            s = s  "%"  Hex(h)  "%"  Hex(l)
        End If
    Next
    URLEncoding = s
End Function

'===================================================================================
' 函數(shù)原型：URLDecoding (sIn)
'功能：URL解碼碼函數(shù)
'參數(shù)：vURL編碼的字符串
'返回值：解碼后的字符串
'涉及的表：無(wú)
'===================================================================================

Public Function URLDecoding(Sin)
    Dim s, i, l, c, t, n
    s = ""
    l = Len(Sin)
    For i = 1 To l
        c = Mid(Sin, i, 1)
        If c>"%" Then
            s = s  c
        Else
            c = Mid(Sin, i + 1, 2)
            i = i + 2
            t = CInt("H"  c)
            If tH80 Then
                s = s  Chr(t)
            Else
                c = Mid(Sin, i + 1, 3)
                If Left(c, 1)>"%" Then
                    URLDecoding = s
                    Exit Function
                Else
                    c = Right(c, 2)
                    n = CInt("H"  c)
                    t = t * 256 + n -65536
                    s = s  Chr(t)
                    i = i + 3
                End If
            End If
        End If
    Next
    URLDecoding = s
End Function

'===================================================================================
' 函數(shù)原型：Bytes2BSTR (v)
'功能：UTF-8編碼轉(zhuǎn)換到正常的GB2312
'參數(shù)：vUTF-8編碼字節(jié)流
'返回值：解碼后的字符串
'涉及的表：無(wú)
'===================================================================================

Public Function Bytes2BSTR(v)
    Dim r, i, t, n
    r = ""
    For i = 1 To LenB(v)
        t = AscB(MidB(v, i, 1))
        If t  H80 Then
            r = r  Chr(t)
        Else
            n = AscB(MidB(v, i + 1, 1))
            r = r  Chr(CLng(t) * H100 + CInt(n))
            i = i + 1
        End If
    Next
    Bytes2BSTR = r
End Function
%>

標(biāo)簽：棗莊衢州蚌埠廣元江蘇萍鄉(xiāng) 衡水大理

巨人網(wǎng)絡(luò)通訊聲明：本文標(biāo)題《ASP常用函數(shù)收藏亂七八糟未整理版》，本文關(guān)鍵詞；如發(fā)現(xiàn)本文內(nèi)容存在版權(quán)問(wèn)題，煩請(qǐng)?zhí)峁┫嚓P(guān)信息告之我們，我們將及時(shí)溝通與處理。本站內(nèi)容系統(tǒng)采集于網(wǎng)絡(luò)，涉及言論、版權(quán)與本站無(wú)關(guān)。

佳木斯湛栽影视文化发展公司

ASP常用函數(shù)收藏亂七八糟未整理版

QQ咨詢

電話咨詢