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
VB 版 Authcode 加解密函数
相关推荐
评论
暂无评论...