Access VBA可用的Base64编码/解码模块-Access交流网触屏版

加密解密安全

Access VBA可用的Base64编码/解码模块

2017-06-21 14:27:56

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

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