VB 版 Authcode 加解密函数

Private Function Authcode(ByVal enstr As String, Optional ByVal operation As String = "DECODE", Optional ByVal keystr As String = "abcd", Optional ByVal expiry As Long = 0, Optional okeylng As Integer = 6) As String

    Dim ckeylng As Integer, key As String, keya As String, keyb As String, keyc As String
    Dim cryptkey() As Byte, keylng As Long, strv() As Byte, str2 As String, valid As String

    Dim box(255) As Long, rndkey(255) As Long, i As Long, J As Long, tmp As Long
    Dim wyh() As Byte, a As Long, tmplng As Long, rs As String, strlng As Long

    On Error GoTo fauthcode
    ckeylng = okeylng

    key = md5(keystr)
    keya = md5(Mid(key, 1, 16))
    keyb = md5(Mid(key, 17, 16))

    If ckeylng <> 0 And ckeylng < 33 Then
        If operation = "DECODE" Then
            keyc = Mid(enstr, 1, ckeylng)
        Else
            keyc = Mid(md5(GetTimes() & Timer() & (Rnd * 100000)), 1, ckeylng)
        End If
    Else
        keyc = ""
    End If

    cryptkey = StrConv(keya + md5(keya & keyc), vbFromUnicode)
    keylng = UBound(cryptkey) + 1

    If operation = "DECODE" Then
        'str2 = DecodeBase64String(Mid(enstr, ckeylng + 1, Len(enstr) - ckeylng))
        strv = DecodeBase64Byte(Mid(enstr, ckeylng + 1, Len(enstr) - ckeylng))
    Else
        If (expiry <= 0) Then
            valid = "0000000000"
        Else
            valid = expiry + GetTimes()
        End If
        str2 = valid + Mid(md5(enstr + keyb), 1, 16) + enstr
        strv = StrConv(str2, vbFromUnicode)
    End If
    'strv = StrConv(str2, vbFromUnicode)
    strlng = UBound(strv)

    For i = 0 To 255
        box(i) = i
    Next
    For i = 0 To 255
        rndkey(i) = cryptkey(i Mod keylng)
    Next
    J = 0
    For i = 0 To 255
        J = (J + box(i) + rndkey(i)) Mod 256
        tmp = box(i)
        box(i) = box(J)
        box(J) = tmp
    Next

    ReDim wyh(strlng)
    a = 0
    J = 0
    For i = 0 To strlng
        a = (a + 1) Mod 256
        J = (J + box(a)) Mod 256
        tmp = box(a)
        box(a) = box(J)
        box(J) = tmp
        tmplng = (box(a) + box(J)) Mod 256
        wyh(i) = strv(i) Xor box(tmplng)

    Next

    If operation = "DECODE" Then
        str2 = StrConv(wyh, vbUnicode)
        If Mid(str2, 1, 10) = "0000000000" Or CLng(Mid(str2, 1, 10)) - GetTimes() > 0 Then
            If Mid(str2, 11, 16) = Mid(md5(Mid(str2, 27, Len(str2) - 26) + keyb), 1, 16) Then
                rs = Mid(str2, 27, Len(str2) - 26)
            Else
                rs = ""
            End If
        Else
            rs = ""
        End If
        Authcode = rs
    Else
        Authcode = keyc & EncodeBase64Byte(wyh)
    End If
    Exit Function
fauthcode:
    Authcode = ""
End Function

转载请注明出处：吖Go博客 » VB 版 Authcode 加解密函数