base64加密模块 用法：Base64Encode(‘加密字符')

Option Explicit
Public Function Base64Encode(InStr1 As String) As String
Dim mInByte(3) As Byte, mOutByte(4) As Byte
Dim myByte As Byte
Dim I As Integer, LenArray As Integer, j As Integer
Dim myBArray() As Byte
Dim OutStr1 As String
myBArray() = StrConv(InStr1, vbFromUnicode)
LenArray = UBound(myBArray) + 1
For I = 0 To LenArray Step 3
If LenArray - I = 0 Then
Exit For
End If
If LenArray - I = 2 Then
mInByte(0) = myBArray(I)
mInByte(1) = myBArray(I + 1)
Base64EncodeByte mInByte, mOutByte, 2
ElseIf LenArray - I = 1 Then
mInByte(0) = myBArray(I)
Base64EncodeByte mInByte, mOutByte, 1
Else
mInByte(0) = myBArray(I)
mInByte(1) = myBArray(I + 1)
mInByte(2) = myBArray(I + 2)
Base64EncodeByte mInByte, mOutByte, 3
End If
For j = 0 To 3
OutStr1 = OutStr1 & Chr(mOutByte(j))
Next j
Next I
Base64Encode = OutStr1
End Function
Private Sub Base64EncodeByte(mInByte() As Byte, mOutByte() As Byte, Num As Integer)
Dim tByte As Byte
Dim I As Integer
If Num = 1 Then
mInByte(1) = 0
mInByte(2) = 0
ElseIf Num = 2 Then
mInByte(2) = 0
End If
tByte = mInByte(0) And &HFC
mOutByte(0) = tByte / 4
tByte = ((mInByte(0) And &H3) * 16) + (mInByte(1) And &HF0) / 16
mOutByte(1) = tByte
tByte = ((mInByte(1) And &HF) * 4) + ((mInByte(2) And &HC0) / 64)
mOutByte(2) = tByte
tByte = (mInByte(2) And &H3F)
mOutByte(3) = tByte
For I = 0 To 3
If mOutByte(I) >= 0 And mOutByte(I) <= 25 Then
mOutByte(I) = mOutByte(I) + Asc("A")
ElseIf mOutByte(I) >= 26 And mOutByte(I) <= 51 Then
mOutByte(I) = mOutByte(I) - 26 + Asc("a")
ElseIf mOutByte(I) >= 52 And mOutByte(I) <= 61 Then
mOutByte(I) = mOutByte(I) - 52 + Asc("0")
ElseIf mOutByte(I) = 62 Then
mOutByte(I) = Asc("+")
Else
mOutByte(I) = Asc("/")
End If
Next I
If Num = 1 Then
mOutByte(2) = Asc("=")
mOutByte(3) = Asc("=")
ElseIf Num = 2 Then
mOutByte(3) = Asc("=")
End If
End Sub
Public Function Base64Decode(InStr1 As String) As String
Dim mInByte(4) As Byte, mOutByte(3) As Byte
Dim I As Integer, LenArray As Integer, j As Integer
Dim myBArray() As Byte
Dim OutStr1 As String
Dim tmpArray() As Byte
myBArray() = StrConv(InStr1, vbFromUnicode)
LenArray = UBound(myBArray)
ReDim tmpArray(((LenArray + 1) / 4) * 3)
j = 0
For I = 0 To LenArray Step 4
If LenArray - I = 0 Then
Exit For
Else
mInByte(0) = myBArray(I)
mInByte(1) = myBArray(I + 1)
mInByte(2) = myBArray(I + 2)
mInByte(3) = myBArray(I + 3)
Base64DecodeByte mInByte, mOutByte, 4
End If
tmpArray(j * 3) = mOutByte(0)
tmpArray(j * 3 + 1) = mOutByte(1)
tmpArray(j * 3 + 2) = mOutByte(2)
j = j + 1
Next I
Base64Decode = BinaryToString(tmpArray)
End Function
Private Sub Base64DecodeByte(mInByte() As Byte, mOutByte() As Byte, ByteNum As Integer)
Dim tByte As Byte
Dim I As Integer
ByteNum = 0
For I = 0 To 3
If mInByte(I) >= Asc("A") And mInByte(I) <= Asc("Z") Then
mInByte(I) = mInByte(I) - Asc("A")
ElseIf mInByte(I) >= Asc("a") And mInByte(I) <= Asc("z") Then
mInByte(I) = mInByte(I) - Asc("a") + 26
ElseIf mInByte(I) >= Asc("0") And mInByte(I) <= Asc("9") Then
mInByte(I) = mInByte(I) - Asc("0") + 52
ElseIf mInByte(I) = Asc("+") Then
mInByte(I) = 62
ElseIf mInByte(I) = Asc("/") Then
mInByte(I) = 63
Else '"="
ByteNum = ByteNum + 1
mInByte(I) = 0
End If
Next I
tByte = (mInByte(0) And &H3F) * 4 + (mInByte(1) And &H30) / 16
mOutByte(0) = tByte
tByte = (mInByte(1) And &HF) * 16 + (mInByte(2) And &H3C) / 4
mOutByte(1) = tByte
tByte = (mInByte(2) And &H3) * 64 + (mInByte(3) And &H3F)
mOutByte(2) = tByte
End Sub
Private Function BinaryToString(ByVal BinaryStr As Variant) As String
Dim lnglen As Long
Dim tmpBin As Variant
Dim strC As String
Dim skipflag As Long
Dim I As Long
skipflag = 0
strC = ""
If Not IsNull(BinaryStr) Then
lnglen = LenB(BinaryStr)
For I = 1 To lnglen
If skipflag = 0 Then
tmpBin = MidB(BinaryStr, I, 1)
If AscB(tmpBin) > 127 Then
strC = strC & Chr(AscW(MidB(BinaryStr, I + 1, 1) & tmpBin))
skipflag = 1
Else
strC = strC & Chr(AscB(tmpBin))
End If
Else
skipflag = 0
End If
Next
End If
BinaryToString = strC
End Function
Private Function StringToBinary(ByVal VarString As String) As Variant
Dim strBin As Variant
Dim varchar As Variant
Dim varasc As Long
Dim varlow, varhigh
Dim I As Long
strBin = ""
For I = 1 To Len(VarString)
varchar = Mid(VarString, I, 1)
varasc = Asc(varchar)
If varasc < 0 Then
varasc = varasc + 65535
End If
If varasc > 255 Then
varlow = Left(Hex(Asc(varchar)), 2)
varhigh = Right(Hex(Asc(varchar)), 2)
strBin = strBin & ChrB("&H" & varlow) & ChrB("&H" & varhigh)
Else
strBin = strBin & ChrB(AscB(varchar))
End If
Next
StringToBinary = strBin
End Function

 

base64解密模块
用法：DecodeBase64String("解密字符")

Next
DecodeBase64Byte = Output
End Function

'将一个字节数组进行Base64编码，并返回字符串
Public Function EncodeBase64Byte(sValue() As Byte) As String
Dim lCtr As Long
Dim lPtr As Long
Dim lLen As Long
Dim sEncoded As String
Dim Bits8(1 To 3) As Byte
Dim Bits6(1 To 4) As Byte
Dim I As Integer
InitBase
For lCtr = 1 To UBound(sValue) + 1 Step 3
For I = 1 To 3
If lCtr + I - 2 <= UBound(sValue) Then
Bits8(I) = sValue(lCtr + I - 2)
lLen = 3
Else
Bits8(I) = 0
lLen = lLen - 1
End If
Next
Bits6(1) = (Bits8(1) And &HFC) \ 4
Bits6(2) = (Bits8(1) And &H3) * &H10 + (Bits8(2) And &HF0) \ &H10
Bits6(3) = (Bits8(2) And &HF) * 4 + (Bits8(3) And &HC0) \ &H40
Bits6(4) = Bits8(3) And &H3F
For lPtr = 1 To lLen + 1
sEncoded = sEncoded & psBase64Chr(Bits6(lPtr))
Next
Next
Select Case lLen + 1
Case 2: sEncoded = sEncoded & "=="
Case 3: sEncoded = sEncoded & "="
Case 4:
End Select
EncodeBase64Byte = sEncoded
End Function
Public Function EncodeBase64String(str2Encode As String) As String
Dim sValue() As Byte
sValue = StrConv(str2Encode, vbFromUnicode)
EncodeBase64String = EncodeBase64Byte(sValue)
End Function
Private Sub InitBase()
Dim iPtr As Integer
For iPtr = 0 To 63
psBase64Chr(iPtr) = Mid$(BASE64CHR, iPtr + 1, 1)
Next
End Sub