Base64编码/解码模块
使用方法，将以下模块代码 复制到Access中的模块中。然后在窗体或其它地方调用即可
Option Explicit
'名称: Base64编码/解码模块
'Name: Base64 Encode & Decode Module
'作者: KiteGirl [中国]
'programmer: KiteGirl [China]
Private priBitMoveTable() As Byte '移位缓冲表
Private priBitMoveTable_CellReady() As Boolean '移位缓冲表标志表
Private priBitMoveTable_Create As Boolean '移位缓冲表创建标志
Private priEncodeTable() As Byte '编码表（素码转Base64）
Private priEncodeTable_Create As Boolean
Private priDecodeTable() As Byte '解码表（Base64转素码）
Private priDecodeTable_Create As Boolean
Private Declare Sub Base64_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDestination As Any, ByRef pSource As Any, ByVal pLength As Long)
Private Const conBase64_CodeTableStrng As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Private Const conBase64_PatchCode As Byte = 61
Private Type tpBase64_Dollop2438 '24Bit(8Bit*3Byte)数据块
btBytes(0 To 2) As Byte
End Type
Private Type tpBase64_Dollop2446 '24Bit(6Bit*4Byte)数据块
btBytes(0 To 3) As Byte
End Type
'解码
Public Sub Base64_Decode(ByRef tOutBytes() As Byte, ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode)
'Base64Decode函数
'语法：[tOutBytes()] = Base64Decode(pBytes(), [pPatchCode])
'功能：将Byte数组表示的Base64编码Ascii字节数组解码为Byte字节数组，并返回。
'参数：byte pBytes() '必要参数。Byte数组表示的Base64编码数据。
' byte pPatchCode '可选参数。冗余字节追加码。默认为61（"="的Ascii码）
'返回：byte tOutBytes() 'Byte数组。
'示例：
' Dim tSurString As String
' Dim tSurBytes() As Byte
' tSurString = "S2l0ZUdpcmzKx7j2usO6otfT"
' tSurBytes() = StrConv(tSurString, vbFromUnicode)
' Dim tDesString As String
' Dim tDesBytes() As Byte
' tDesBytes() = Base64Decode(tSurBytes())
' tDesString = StrConv(tDesBytes(), vbUnicode) 'tDesString返回"KiteGirl是个好孩子"
Dim tOutBytes_Length As Long
Dim tBytes_Length As Long
Dim tBytes2446() As Byte
Dim tSurBytes_Length As Long
Dim tDesBytes_Length As Long
Err.Clear
On Error Resume Next
tBytes_Length = UBound(pBytes())
If CBool(Err.Number) Then Exit Sub
tBytes2446() = BytesPrimeDecode(pBytes())
tOutBytes() = Bytes2438GetBy2446(tBytes2446())
Dim tPatchNumber As Long
Dim tIndex As Long
Dim tBytesIndex As Long
For tIndex = 0 To 1
tBytesIndex = tBytes_Length - tIndex
tPatchNumber = tPatchNumber + ((pBytes(tIndex) = pPatchCode) And 1)
Next
tSurBytes_Length = tBytes_Length - tPatchNumber
tDesBytes_Length = (tSurBytes_Length * 3) / 4
ReDim Preserve tOutBytes(tDesBytes_Length)
End Sub
'编码
Public Sub Base64_Encode(ByRef tOutBytes() As Byte, ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode)
'Base64Encode函数
'语法：[tOutBytes()] = Base64Encode(pBytes(), [pPatchCode])
'功能：将Byte数组编码为Base64编码的Ascii字节数组，并返回。
'参数：byte pBytes() '必要参数。Byte数组表示的数据。
' byte pPatchCode '可选参数。冗余字节追加码。默认为61（"="的Ascii码）
'返回：byte tOutBytes() 'Base64编码表示的Ascii代码数组。
'注意：如果你想在VB里以字符串表示该函数的返回值，需要用StrConv转换为Unicode。
'示例：
' Dim tSurString As String
' Dim tSurBytes() As Byte
' tSurString = "KiteGirl是个好孩子"
' tSurBytes() = StrConv(tSurString, vbFromUnicode)
' Dim tDesString As String
' Dim tDesBytes() As Byte
' tDesBytes() = Base64Encode(tSurBytes())
' tDesString = StrConv(tDesBytes(), vbUnicode) 'tDesString返回"S2l0ZUdpcmzKx7j2usO6otfT"
Dim tOutBytes_Length As Long
Dim tBytes2446() As Byte
Dim tSurBytes_Length As Long
Dim tDesBytes_Length As Long
Err.Clear
On Error Resume Next
tSurBytes_Length = UBound(pBytes())
If CBool(Err.Number) Then Exit Sub
tBytes2446() = Bytes2438PutTo2446(pBytes())
tOutBytes() = BytesPrimeEncode(tBytes2446())
tOutBytes_Length = UBound(tOutBytes())
Dim tPatchNumber As Long
tDesBytes_Length = (tSurBytes_Length * 4 + 3) / 3
tPatchNumber = tOutBytes_Length - tDesBytes_Length
Dim tIndex As Long
Dim tBytesIndex As Long
For tIndex = 1 To tPatchNumber
tBytesIndex = tOutBytes_Length - tIndex + 1
tOutBytes(tBytesIndex) = pPatchCode
Next
End Sub
Private Function BytesPrimeDecode(ByRef pBytes() As Byte) As Byte()
'功能：将Base64数组解码为素码数组
Dim tOutBytes() As Byte
Dim tBytes_Length As Long
Err.Clear
On Error Resume Next
tBytes_Length = UBound(pBytes())
If CBool(Err.Number) Then Exit Function
ReDim tOutBytes(tBytes_Length)
If Not priDecodeTable_Create Then Base64CodeTableCreate
Dim tIndex As Long
For tIndex = 0 To tBytes_Length
tOutBytes(tIndex) = priDecodeTable(pBytes(tIndex))
Next
BytesPrimeDecode = tOutBytes()
End Function
Private Function BytesPrimeEncode(ByRef pBytes() As Byte) As Byte()
'功能：将素码数组编码为Base64数组
Dim tOutBytes() As Byte
Dim tBytes_Length As Long
Err.Clear
On Error Resume Next
tBytes_Length = UBound(pBytes())
If CBool(Err.Number) Then Exit Function
ReDim tOutBytes(tBytes_Length)
If Not priEncodeTable_Create Then Base64CodeTableCreate
Dim tIndex As Long
For tIndex = 0 To tBytes_Length
tOutBytes(tIndex) = priEncodeTable(pBytes(tIndex))
Next
BytesPrimeEncode = tOutBytes()
End Function
Private Sub Base64CodeTableCreate(Optional ByVal pString As String = conBase64_CodeTableStrng)
'功能：根据字符串提供的代码初始化Base64解码/编码码表。
Dim tBytes() As Byte
Dim tBytes_Length As Long
tBytes() = pString
tBytes_Length = UBound(tBytes())
If Not tBytes_Length = 127 Then
' MsgBox "编码/解码表初始化失败", , "错误"
Exit Sub
End If
Dim tIndex As Byte
ReDim priEncodeTable(0 To 255)
ReDim priDecodeTable(0 To 255)
Dim tTableIndex As Byte
Dim tByteValue As Byte
For tIndex = 0 To tBytes_Length Step 2
tTableIndex = tIndex / 2
tByteValue = tBytes(tIndex)
priEncodeTable(tTableIndex) = tByteValue
priDecodeTable(tByteValue) = tTableIndex
Next
priEncodeTable_Create = True
priDecodeTable_Create = True
End Sub
Private Function Bytes2438GetBy2446(ByRef pBytes() As Byte) As Byte()
'功能：将素码转换为字节。
Dim tOutBytes() As Byte
Dim tDollops2438() As tpBase64_Dollop2438
Dim tDollops2446() As tpBase64_Dollop2446
tDollops2446() = BytesPutTo2446(pBytes())
tDollops2438() = Dollops2438GetBy2446(tDollops2446())
tOutBytes() = BytesGetBy2438(tDollops2438())
Bytes2438GetBy2446 = tOutBytes()
End Function
Private Function Bytes2438PutTo2446(ByRef pBytes() As Byte) As Byte()
'功能：将字节转换为素码。
Dim tOutBytes() As Byte
Dim tDollops2438() As tpBase64_Dollop2438
Dim tDollops2446() As tpBase64_Dollop2446
tDollops2438() = BytesPutTo2438(pBytes())
tDollops2446() = Dollops2438PutTo2446(tDollops2438())
tOutBytes() = BytesGetBy2446(tDollops2446())
Bytes2438PutTo2446 = tOutBytes()
End Function
Private Function BytesGetBy2446(ByRef p2446() As tpBase64_Dollop2446) As Byte()
'功能：2446数组转换为字节数组
Dim tOutBytes() As Byte
Dim tOutBytes_Length As Long
Dim t2446Length As Long
Err.Clear
On Error Resume Next
t2446Length = UBound(p2446())
If CBool(Err.Number) Then Exit Function
tOutBytes_Length = t2446Length * 4 + 3
ReDim tOutBytes(0 To tOutBytes_Length)
Dim tCopyLength As Long
tCopyLength = tOutBytes_Length + 1
Base64_CopyMemory tOutBytes(0), p2446(0), tCopyLength
BytesGetBy2446 = tOutBytes()
End Function
Private Function BytesPutTo2446(ByRef pBytes() As Byte) As tpBase64_Dollop2446()
'功能：字节数组转换为2446数组
Dim tOut2446() As tpBase64_Dollop2446
Dim tOut2446_Length As Long
Dim tBytesLength As Long
Err.Clear
On Error Resume Next
tBytesLength = UBound(pBytes())
If CBool(Err.Number) Then Exit Function
tOut2446_Length = tBytesLength / 4
ReDim tOut2446(0 To tOut2446_Length)
Dim tCopyLength As Long
tCopyLength = tBytesLength + 1
Base64_CopyMemory tOut2446(0), pBytes(0), tCopyLength
BytesPutTo2446 = tOut2446()
End Function
Private Function BytesGetBy2438(ByRef p2438() As tpBase64_Dollop2438) As Byte()
'功能：2438数组转换为字节数组
Dim tOutBytes() As Byte
Dim tOutBytes_Length As Long
Dim t2438Length As Long
Err.Clear
On Error Resume Next
t2438Length = UBound(p2438())
If CBool(Err.Number) Then Exit Function
tOutBytes_Length = t2438Length * 3 + 2
ReDim tOutBytes(0 To tOutBytes_Length)
Dim tCopyLength As Long
tCopyLength = tOutBytes_Length + 1
Base64_CopyMemory tOutBytes(0), p2438(0), tCopyLength
BytesGetBy2438 = tOutBytes()
End Function
Private Function BytesPutTo2438(ByRef pBytes() As Byte) As tpBase64_Dollop2438()
'功能：字节数组转换为2438数组
Dim tOut2438() As tpBase64_Dollop2438
Dim tOut2438_Length As Long
Dim tBytesLength As Long
Err.Clear
On Error Resume Next
tBytesLength = UBound(pBytes())
If CBool(Err.Number) Then Exit Function
tOut2438_Length = tBytesLength / 3
ReDim tOut2438(0 To tOut2438_Length)
Dim tCopyLength As Long
tCopyLength = tBytesLength + 1
Base64_CopyMemory tOut2438(0), pBytes(0), tCopyLength
BytesPutTo2438 = tOut2438()
End Function
Private Function Dollops2438GetBy2446(ByRef p2446() As tpBase64_Dollop2446) As tpBase64_Dollop2438()
'功能：2446块数组转换为2438块数组
Dim tOut2438() As tpBase64_Dollop2438
Dim tOut2438_Length As Long
Dim t2446_Length As Long
Err.Clear
On Error Resume Next
If CBool(Err.Number) Then Exit Function
t2446_Length = UBound(p2446())
tOut2438_Length = t2446_Length
ReDim tOut2438(tOut2438_Length)
Dim tIndex As Long
For tIndex = 0 To t2446_Length
tOut2438(tIndex) = Dollop2438GetBy2446(p2446(tIndex))
Next
Dollops2438GetBy2446 = tOut2438()
End Function
Private Function Dollops2438PutTo2446(ByRef p2438() As tpBase64_Dollop2438) As tpBase64_Dollop2446()
'功能：2438块数组转换为2446块数组
Dim tOut2446() As tpBase64_Dollop2446
Dim tOut2446_Length As Long
Dim t2438_Length As Long
Err.Clear
On Error Resume Next
If CBool(Err.Number) Then Exit Function
t2438_Length = UBound(p2438())
tOut2446_Length = t2438_Length
ReDim tOut2446(tOut2446_Length)
Dim tIndex As Long
For tIndex = 0 To t2438_Length
tOut2446(tIndex) = Dollop2438PutTo2446(p2438(tIndex))
Next
Dollops2438PutTo2446 = tOut2446()
End Function
Private Function Dollop2438GetBy2446(ByRef p2446 As tpBase64_Dollop2446) As tpBase64_Dollop2438
'功能：2446块转换为2438块
Dim tOut2438 As tpBase64_Dollop2438
With tOut2438
.btBytes(0) = ByteBitMove(p2446.btBytes(0), 2) + ByteBitMove(p2446.btBytes(1), -4)
.btBytes(1) = ByteBitMove(p2446.btBytes(1), 4) + ByteBitMove(p2446.btBytes(2), -2)
.btBytes(2) = ByteBitMove(p2446.btBytes(2), 6) + ByteBitMove(p2446.btBytes(3), 0)
End With
Dollop2438GetBy2446 = tOut2438
End Function
Private Function Dollop2438PutTo2446(ByRef p2438 As tpBase64_Dollop2438) As tpBase64_Dollop2446
'功能：2438块转换为2446块
Dim tOut2446 As tpBase64_Dollop2446
With tOut2446
.btBytes(0) = ByteBitMove(p2438.btBytes(0), -2, 63)
.btBytes(1) = ByteBitMove(p2438.btBytes(0), 4, 63) + ByteBitMove(p2438.btBytes(1), -4, 63)
.btBytes(2) = ByteBitMove(p2438.btBytes(1), 2, 63) + ByteBitMove(p2438.btBytes(2), -6, 63)
.btBytes(3) = ByteBitMove(p2438.btBytes(2), 0, 63)
End With
Dollop2438PutTo2446 = tOut2446
End Function
Private Function ByteBitMove(ByVal pByte As Byte, ByVal pMove As Integer, Optional ByVal pConCode As Byte = &HFF) As Byte
'功能：对Byte进行移位（带饱和缓冲功能）。
Dim tOutByte As Byte
If Not priBitMoveTable_Create Then
ReDim priBitMoveTable(0 To 255, -8 To 8)
ReDim priBitMoveTable_CellReady(0 To 255, -8 To 8)
priBitMoveTable_Create = True
End If
If Not priBitMoveTable_CellReady(pByte, pMove) Then
priBitMoveTable(pByte, pMove) = ByteBitMove_Operation(pByte, pMove)
priBitMoveTable_CellReady(pByte, pMove) = True
End If
tOutByte = priBitMoveTable(pByte, pMove) And pConCode
ByteBitMove = tOutByte
End Function
Private Function ByteBitMove_Operation(ByVal pByte As Byte, ByVal pMove As Integer) As Byte
'功能：对Byte进行算术移位。
Dim tOutByte As Byte
Dim tMoveLeft As Boolean
Dim tMoveRight As Boolean
Dim tMoveCount As Integer
tMoveLeft = pMove > 0
tMoveRight = pMove < 0
tMoveCount = Abs(pMove)
If tMoveLeft Then
tOutByte = (pByte Mod (2 ^ (8 - tMoveCount))) * (2 ^ tMoveCount)
ElseIf tMoveRight Then
tOutByte = pByte / 2 ^ tMoveCount
Else
tOutByte = pByte
End If
ByteBitMove_Operation = tOutByte
End Function
其它加解密
Public keyCode As String '密钥
Private keySingle As String '单引号
Private keyDouble As String '双引号
'对外公开的加密函数，过滤掉单引号和双引号
Public Function Encrypt(ByVal strValue As String) As String
Dim strKeyCode As String
strKeyCode = Trim(keyCode)
If Len(strKeyCode) > 10 Then
Encrypt = "密钥最长10位"
Exit Function
End If
'处理密钥,特意不对称
'[FS+KC] [/FS-KC]
'此处假定文本中永远不会同时出现[FS+KC]与[/FS-KC]
If Len(strKeyCode) Then
strKeyCode = "[FS+KC]" & strKeyCode & "[/FS-KC]"
Else
strKeyCode = ""
End If
'释放掉
keyCode = ""
Encrypt = myEncrypt(strValue & strKeyCode)
End Function
'对外公开的解密函数
Public Function UnEncrypt(ByVal strValue As String) As String
Dim strKeyCode As String
Dim strInKeyCode As String
Dim strReturn As String
Dim blnUsedKeyCode As Boolean
Dim lKeyStart As Long
Dim lKeyEnd As String
strKeyCode = Trim(keyCode)
If Len(strKeyCode) > 10 Then
UnEncrypt = "-3"
Exit Function
End If
'首先进行解密
strReturn = myUnEncrypt(strValue)
'判断是否使用了密钥
'取最后一个位置的标记
If InStrRev(strReturn, "[FS+KC]") > 0 And Right(strReturn, 8) = "[/FS-KC]" Then
blnUsedKeyCode = True
End If
'' '处理异常空格，其实不是真正的空格，而是255的不可见字符
Dim i As Long
Dim strReturn2 As String
Dim strChar As String
For i = 1 To Len(strReturn)
strChar = Mid(strReturn, i, 1)
If Asc(strChar) <> 255 Then
strReturn2 = strReturn2 & strChar
End If
Next
strReturn = strReturn2
'如果使用了密钥
If blnUsedKeyCode Then
'如果未输入密钥
If strKeyCode = "" Then
UnEncrypt = "-2"
'判断密钥
Else
'取出密钥文本
lKeyStart = InStrRev(strReturn, "[FS+KC]") + Len("[FS+KC]")
lKeyEnd = InStrRev(strReturn, "[/FS-KC]")
strInKeyCode = Mid(strReturn, lKeyStart, lKeyEnd - lKeyStart)
If strKeyCode <> strInKeyCode Then
'密钥错误
UnEncrypt = "-1"
Exit Function
Else
'返回准确文本
strReturn = Left(strReturn, Len(strReturn) - Len("[FS+KC]" & strKeyCode & "[/FS-KC]"))
UnEncrypt = strReturn
Exit Function
End If
End If
Else
UnEncrypt = strReturn
End If
End Function
'加密函数
Private Function myEncrypt(ByVal strValue As String) As String
Randomize
Dim ll As Long
Dim AscNumber As Long
Dim i As Long
Dim HH As String
Dim ss As String
Dim mm As String
Dim J As Long
Dim Temp As String
Dim Temp2 As String
Dim Temp1 As String
Dim temp3 As String
Dim temp4 As String
ll = Len(strValue) '加密字符长度
If ll = 0 Then
myEncrypt = ""
Else
'**************************************
i = 1
For i = 1 To ll
AscNumber = Asc(Mid(strValue, i, 1)) '取ASC码
HH = Hex(AscNumber) '换成16进制码
If Len(HH) < 2 Then '不够二位的补0
HH = "0" & HH
End If
'拆开(可能任意多位)
For J = 1 To Len(HH)
ss = Mid(HH, J, 1)
Select Case ss
Case "0"
mm = "0000"
Case "1"
mm = "0001"
Case "2"
mm = "0010"
Case "3"
mm = "0011"
Case "4"
mm = "0100"
Case "5"
mm = "0101"
Case "6"
mm = "0110"
Case "7"
mm = "0111"
Case "8"
mm = "1000"
Case "9"
mm = "1001"
Case "A"
mm = "1010"
Case "B"
mm = "1011"
Case "C"
mm = "1100"
Case "D"
mm = "1101"
Case "E"
mm = "1110"
Case "F"
mm = "1111"
End Select
Temp = Temp & mm
Next J
Next i
'**************************************
' Debug.Print "G", temp
Temp2 = ""
temp3 = ""
i = 1
'Len(Temp)必定为偶数
For i = 1 To Len(Temp)
'拆偶数位
If i / 2 = Int(i / 2) Then
Temp2 = Temp2 & Mid(Temp, i, 1)
'拆奇数位
Else
temp3 = temp3 & Mid(Temp, i, 1)
End If
Next
Temp = Temp2 & temp3
'**************************************
'把最右面7位移到前面
Temp1 = Right(Temp, 7)
Temp = Temp1 & Left(Temp, Len(Temp) - 7)
'左右各半互换
Temp1 = Left(Temp, Len(Temp) / 2)
Temp = Right(Temp, Len(Temp) / 2) & Temp1
'取从中间位置开始往后取2位
Temp1 = Mid(Temp, Len(Temp) / 2, 2)
'组合在字串的前后，因为仍然保持了4的偶数倍，所以仍然能错位返回成字符
Temp = Temp1 & Temp & Temp1
'**************************************
Temp1 = ""
ss = ""
mm = ""
J = 1
'将二进制还原成字母
For J = 1 To Len(Temp) Step 4
ss = Mid(Temp, J, 4)
Select Case ss
Case "0000"
mm = "F"
Case "0001"
mm = "b"
Case "0010"
mm = "2"
Case "0011"
mm = "P"
Case "0100"
mm = "V"
Case "0101"
mm = "j"
Case "0110"
mm = "W"
Case "0111"
mm = "N"
Case "1000"
mm = "q"
Case "1001"
mm = "m"
Case "1010"
mm = "7"
Case "1011"
mm = "i"
Case "1100"
mm = "d"
Case "1101"
mm = "c"
Case "1110"
mm = "L"
Case "1111"
mm = "z"
End Select
Temp1 = Temp1 & mm
Next J
Temp = Temp1
'**************************************
i = 1
Temp1 = ""
For i = 1 To Len(Temp)
Temp1 = Temp1 & Chr(Asc(Mid(Temp, i, 1)) Xor 17)
Next i
Temp = Temp1
'**************************************
i = 1
Temp1 = ""
For i = 1 To Len(Temp)
Temp2 = Chr(Int(Rnd * 25))
temp3 = Chr(Asc(Mid(Temp, i, 1)) Xor Asc(Temp2))
Temp1 = Temp1 & temp3 & Chr(Asc(Temp2) + 65)
Next i
'**************************************
Temp = Temp1
'处理单引号和双引号
Temp = Replace(Temp, Chr(39), "Tr]3[9")
Temp = Replace(Temp, Chr(34), "HPr{3")
myEncrypt = Temp
End If
End Function
