Access 下Base64位加密（支持中文和特殊符号）
来自网络
这个Access类模块可实现功能：
1.Access加密字符串函数 Base64编码函数（加密）
2.Access解密字符串函数 Base64解码函数（加密）
3.Access加密整个文件函数
4.Access解密整个文件函数
5.Access加密解密字节数组
6.Access二进制与字符串相互转换
7.去掉字符串尾等
此Access加密解密类模块如下
Option Explicit
' 1、加密字符串函数 Base64编码函数（加密）
' 参数：源字符串（明文）
' 返回：加密后的字符串
Public Function Base64StringEncode(InStr1 As String) As String
On Error GoTo Err2
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
Base64StringEncode = OutStr1
Exit Function
Err2:
Base64StringEncode = ""
Debug.Print "函数(CBase64EnDeCode.Base64StringEncode) 出错 " & Err.Number & " (" & Err.Description & ")"
End Function
' 2、解密字符串函数 Base64解码函数（加密）
' 参数：源字符串（密文）
' 返回：解密后的字符串
Public Function Base64StringDecode(InStr1 As String) As String
On Error GoTo Err2
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
Base64StringDecode = StripNulls(BinaryToString(tmpArray))
Exit Function
Err2:
Base64StringDecode = ""
Debug.Print "函数(CBase64EnDeCode.Base64StringDecode) 出错 " & Err.Number & " (" & Err.Description & ")"
End Function
' 3、加密文件函数
' 参数：明文文件名，密文文件名
' 返回：无
Public Sub Base64FileEncode(PlaintextFileName As String, CiphertextFileName As String)
On Error GoTo Err2
Dim Plaintext As String, Ciphertext As String ' 明文和密文文字！
' 打开明文文件
Open PlaintextFileName For Binary Access Read As #1
Plaintext = Input(LOF(1), #1)
Close #1
' 文件内容加密
Ciphertext = Base64StringEncode(Plaintext)
' 写入密文到文件！
Open CiphertextFileName For Binary Access Write As #1
Put #1, , Ciphertext
Close #1
Exit Sub
Err2:
Debug.Print "函数(CBase64EnDeCode.Base64FileEncode) 出错 " & Err.Number & " (" & Err.Description & ")"
End Sub
' 4、解密文件函数
' 参数：明文文件名，密文文件名
' 返回：无
Public Sub Base64FileDecode(PlaintextFileName As String, CiphertextFileName As String)
On Error GoTo Err2
Dim Plaintext As String, Ciphertext As String ' 明文和密文文字！
' 读入密文文件
Open CiphertextFileName For Binary Access Read As #1
Ciphertext = Input(LOF(1), #1)
Close #1
' 解密密文
Plaintext = Base64StringDecode(Ciphertext)
' 将解密后的文字写入文件
Open PlaintextFileName For Binary Access Write As #1
Put #1, , Plaintext
Close #1
Exit Sub
Err2:
Debug.Print "函数(CBase64EnDeCode.Base64FileDecode) 出错 " & Err.Number & " (" & Err.Description & ")"
End Sub
' 加密字节数组
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
' 解密字节数组
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
'0的六位和1的前两位
mOutByte(0) = tByte
tByte = (mInByte(1) And &HF) * 16 + (mInByte(2) And &H3C) / 4
'1的后四位和2的前四位
mOutByte(1) = tByte
tByte = (mInByte(2) And &H3) * 64 + (mInByte(3) And &H3F)
mOutByte(2) = tByte
'2的后两位和3的六位
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
' 去掉字符串尾
Private Function StripNulls(OriginalStr As String) As String
' This removes the extra Nulls so String comparisons will work
If (InStr(OriginalStr, Chr$(0)) > 0) Then
OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr$(0)) - 1)
End If
StripNulls = OriginalStr
End Function
