VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "Base64" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '************************************************************************************* 'Base 64 Encoding class ' 'Author: Wil Johnson ' [email protected] ' 'Version: 1.1 ' 'Date: 3/21/2000 ' 'Notes: ' This code is for example purposes only, and is provided as-is. While it has ' worked well under limited testing, the current error handling is minimal and ' should be expanded upon before release into a production environment. Please ' report all bugs found to the author for correction, even if you have already ' corrected them yourself. ' ' Again, this code is a rough draft. Feel free to use it, but do so at your own ' risk. These release notes must also remain intact. ' '************************************************************************************* Option ExplicitPrivate m_bytIndex(0 To 63) As Byte Private m_bytReverseIndex(0 To 255) As BytePrivate Const k_bytEqualSign As Byte = 61Private Const k_bytMask1 As Byte = 3 '00000011 Private Const k_bytMask2 As Byte = 15 '00001111 Private Const k_bytMask3 As Byte = 63 '00111111Private Const k_bytMask4 As Byte = 192 '11000000 Private Const k_bytMask5 As Byte = 240 '11110000 Private Const k_bytMask6 As Byte = 252 '11111100Private Const k_bytShift2 As Byte = 4 Private Const k_bytShift4 As Byte = 16 Private Const k_bytShift6 As Byte = 64 Private Const k_lMaxBytesPerLine As Long = 152Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Public Function Encode(ByRef sInput As String) As String If sInput = "" Then Exit Function Dim bytTemp() As Byte bytTemp = StrConv(sInput, vbFromUnicode) Encode = EncodeArr(bytTemp) End FunctionPublic Function EncodeFromFile(sFileName As String) As String On Error GoTo ErrorHandler: Dim bytFile() As Byte Dim iFile As Integer
'get new file handle iFile = FreeFile Open sFileName For Input As #iFile 'size the array to the size of the file ReDim bytFile(0 To VBA.LOF(iFile) - 1) As Byte 'get everything in the file Input #iFile, bytFile Close #iFile
'encode it EncodeFromFile = EncodeArr(bytFile)
GoTo Done:
ErrorHandler: EncodeFromFile = "" Resume Done:Done: On Error Resume Next Close #iFile
End Function
Public Function EncodeArr(ByRef bytInput() As Byte) As String On Error GoTo ErrorHandler: Dim bytWorkspace() As Byte 'array for the "rough draft" of the encoded data Dim bytResult() As Byte 'array for the "final draft" Dim bytCrLf(0 To 3) As Byte 'array that will contain vbCrLf, for CopyMemory purposes
Dim lCounter As Long 'counter used to iterate through input bytes Dim lWorkspaceCounter As Long 'counter used to iterate through workspace bytes Dim lLineCounter As Long 'counter used when inserting CrLfs Dim lCompleteLines As Long 'used for calculations when inserting CrLfs Dim lBytesRemaining As Long 'used to determine how much work is left after coming out of a loop 'pointers Dim lpWorkSpace As Long 'pointer to bytWorkspace. it's offset will change as bytes are copied out of the array Dim lpResult As Long 'pointer to bytResult. it's offset will also change Dim lpCrLf As Long 'pointer to bytCrLf. it is not offset and will not change 'create a workspace larger than we need 'this is to prevent VB from having to allocate memory constantly If UBound(bytInput) < 1024 Then ReDim bytWorkspace(LBound(bytInput) To (LBound(bytInput) + 4096)) As Byte Else ReDim bytWorkspace(LBound(bytInput) To (UBound(bytInput) * 4)) As Byte End If lWorkspaceCounter = LBound(bytWorkspace) 'step through in 3 byte increments For lCounter = LBound(bytInput) To (UBound(bytInput) - ((UBound(bytInput) Mod 3) + 3)) Step 3 'result set byte 1 = 6 most significant bits of first byte of input set 'bits are right shifted by 2 bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
'result set byte 2 = 2 least significant bits of first byte and 4 most significant bits of second byte of input set 'bits from first byte are left shifted by 4 'bits from second byte are right shifted by 4 bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
'result set byte 3 = 4 least significant bits of second byte and 2 most significant bits of third byte of input set 'bits from second byte are left shifted by 2 'bits from third byte are right shifted by 6 bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex(((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2) + (bytInput(lCounter + 2) \ k_bytShift6))
'result set byte 4 = 6 least significant bits of third byte of input set 'bits from third byte are not shifted at all bytWorkspace(lWorkspaceCounter + 6) = m_bytIndex(bytInput(lCounter + 2) And k_bytMask3) lWorkspaceCounter = lWorkspaceCounter + 8 Next lCounter Select Case (UBound(bytInput) Mod 3): 'for information on how bits are masked and shifted, see above Case 0: bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2)) bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex((bytInput(lCounter) And k_bytMask1) * k_bytShift4) bytWorkspace(lWorkspaceCounter + 4) = k_bytEqualSign bytWorkspace(lWorkspaceCounter + 6) = k_bytEqualSign
End Select lWorkspaceCounter = lWorkspaceCounter + 8 'base64 encoding allows no more than 76 characters per line, 'which translates to 152 bytes since the string is unicode If lWorkspaceCounter <= k_lMaxBytesPerLine Then 'no need to line wrap. EncodeArr = Left$(bytWorkspace, InStr(1, bytWorkspace, Chr$(0)) - 1) 'EncodeArr = bytWorkspace Else 'must wrap lines 'first, populate the CrLf byte array bytCrLf(0) = 13 bytCrLf(1) = 0 bytCrLf(2) = 10 bytCrLf(3) = 0
'size the end result array ReDim bytResult(LBound(bytWorkspace) To UBound(bytWorkspace))
'get pointers to the various arrays lpWorkSpace = VarPtr(bytWorkspace(LBound(bytWorkspace))) lpResult = VarPtr(bytResult(LBound(bytResult))) lpCrLf = VarPtr(bytCrLf(LBound(bytCrLf)))
'get count of complete lines lCompleteLines = Fix(lWorkspaceCounter / k_lMaxBytesPerLine)
For lLineCounter = 0 To lCompleteLines 'copy first line CopyMemory lpResult, lpWorkSpace, k_lMaxBytesPerLine
'offset the workspace and result pointers by k_lMaxBytesPerLine lpWorkSpace = lpWorkSpace + k_lMaxBytesPerLine lpResult = lpResult + k_lMaxBytesPerLine
'copy CrLf to result CopyMemory lpResult, lpCrLf, 4&
'offset result pointer by another 4 bytes to account for the CrLf lpResult = lpResult + 4& Next lLineCounter
'check if there are any remaining bytes in an incomplete line to be copied lBytesRemaining = lWorkspaceCounter - (lCompleteLines * k_lMaxBytesPerLine) If lBytesRemaining > 0 Then 'copy remaining bytes to result CopyMemory lpResult, lpWorkSpace, lBytesRemaining End If
'no need to resize the result before passing it back to a string, 'since the empty space is made up of null chars that will terminate the 'string automatically. 'CopyMemory StrPtr(EncodeArr), VarPtr(bytResult(LBound(bytResult))), lpResult + lBytesRemaining EncodeArr = Left$(bytResult, InStr(1, bytResult, Chr$(0)) - 1) End If
Exit FunctionErrorHandler: 'on error just return an empty array Erase bytResult EncodeArr = bytResult End FunctionPublic Function Decode(sInput As String) As String If sInput = "" Then Exit Function Decode = StrConv(DecodeArr(sInput), vbUnicode) End FunctionPublic Sub DecodeToFile(sInput As String, sFileName As String) On Error GoTo ErrorHandler: Dim iFile As Integer
'do not overwrite existing files If Dir(sFileName) <> "" Then Err.Raise vbObjectError + 1000, "Base64.DecodeToFile", "File already exists." GoTo Done: End If
iFile = FreeFile Open sFileName For Binary As #iFile Put #iFile, , DecodeArr(sInput) Close #iFile
Public Function DecodeArr(sInput As String) As Byte() 'returns a SBCS byte array Dim bytInput() As Byte 'base64 encoded string to work with Dim bytWorkspace() As Byte 'byte array to use as workspace Dim bytResult() As Byte 'array that result will be copied to Dim lInputCounter As Long 'iteration counter for input array Dim lWorkspaceCounter As Long 'iteration counter for workspace array
'get rid of CrLfs, and "="s since they're not required for decoding, 'and place the input in the byte array bytInput = Replace(Replace(sInput, vbCrLf, ""), "=", "")
'size the workspace ReDim bytWorkspace(LBound(bytInput) To (UBound(bytInput) * 2)) As Byte lWorkspaceCounter = LBound(bytWorkspace)
'pass bytes back through index to get original values For lInputCounter = LBound(bytInput) To UBound(bytInput) bytInput(lInputCounter) = m_bytReverseIndex(bytInput(lInputCounter)) Next lInputCounter
For lInputCounter = LBound(bytInput) To (UBound(bytInput) - ((UBound(bytInput) Mod 8) + 8)) Step 8 'left shift first input byte by 2 and right shift second input byte by 4 bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
'mask bits 5-8 of second byte, left shift it by 4 'right shift third byte by 2, add it to result of second byte bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + _ (bytInput(lInputCounter + 4) \ k_bytShift2)
'mask bits 3-8 of third byte, left shift it by 6, add it to fourth byte bytWorkspace(lWorkspaceCounter + 2) = ((bytInput(lInputCounter + 4) And k_bytMask1) * k_bytShift6) + _ bytInput(lInputCounter + 6)
lWorkspaceCounter = lWorkspaceCounter + 3 Next lInputCounter
'decode any remaining bytes that are not part of a full 4 byte block Select Case (UBound(bytInput) Mod 8): Case 3: 'left shift first input byte by 2 and right shift second input byte by 4 bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
Case 5: 'left shift first input byte by 2 and right shift second input byte by 4 bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
'mask bits 5-8 of second byte, left shift it by 4 'right shift third byte by 2, add it to result of second byte bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + _ (bytInput(lInputCounter + 4) \ k_bytShift2) lWorkspaceCounter = lWorkspaceCounter + 1
Case 7: 'left shift first input byte by 2 and right shift second input byte by 4 bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
'mask bits 5-8 of second byte, left shift it by 4 'right shift third byte by 2, add it to result of second byte bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + _ (bytInput(lInputCounter + 4) \ k_bytShift2)
'mask bits 3-8 of third byte, left shift it by 6, add it to fourth byte bytWorkspace(lWorkspaceCounter + 2) = ((bytInput(lInputCounter + 4) And k_bytMask1) * k_bytShift6) + _ bytInput(lInputCounter + 6) lWorkspaceCounter = lWorkspaceCounter + 2
End Select
'size the result array ReDim bytResult(LBound(bytWorkspace) To lWorkspaceCounter) As Byte
'if option base is set to 1 then don't increment this value If LBound(bytWorkspace) = 0 Then lWorkspaceCounter = lWorkspaceCounter + 1 End If
中国人当用中国货，这是中国姑娘KiteGirl写的（100%自己写的代码）。Attribute VB_Name = "modBase64" '名称: Base64编码/解码模块 'Name: Base64 Encode & Decode Module'作者: KiteGirl [中国] 'coder: KiteGirl [China]'[定义部]'数据结构Option ExplicitPublic Type tpBase64_Dollop2438 '24Bit(8Bit*3Byte)数据块 btBytes(0 To 2) As Byte End TypePublic Type tpBase64_Dollop2446 '24Bit(6Bit*4Byte)数据块 btBytes(0 To 3) As Byte End Type'数据表'priBitMoveTable - 移位缓冲表 [D.R.C]Private priBitMoveTable() As Byte '移位缓冲表 Private priBitMoveTable_CellReady() As Boolean '移位缓冲表标志表 Private priBitMoveTable_Create As Boolean '移位缓冲表创建标志'priEncodeTable - 编码表 [D.C]Private priEncodeTable() As Byte '编码表（素码转Base64） Private priEncodeTable_Create As Boolean'priDecodeTable - 解码表 [D.C]Private priDecodeTable() As Byte '解码表（Base64转素码） Private priDecodeTable_Create As Boolean'常量'conBase64_CodeTableStrng 'Base64默认编码表(字符串)Public Const conBase64_CodeTableStrng As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"'conBase64_PatchCode 'Base64默认追加码(Ascii)Public Const conBase64_PatchCode As Byte = 61Private Declare Sub Base64_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDestination As Any, ByRef pSource As Any, ByVal pLength As Long)'[Ⅰ层]Public Function Base64Decode(ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode) As Byte() Attribute Base64Decode.VB_Description = "将Byte数组表示的Base64编码Ascii字节数组解码为Byte字节数组，并返回。" '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() As Byte Dim tOutBytes_Length As Long
Dim tBytes_Length As Byte
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) Or tSurBytes_Length < 0 Then Exit Function
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
Dim tIndex As Long Dim tBytesIndex As Long For tIndex = 1 To tPatchNumber tBytesIndex = tOutBytes_Length - tIndex + 1& tOutBytes(tBytesIndex) = pPatchCode Next Base64Encode = tOutBytes() End Function
'[Ⅱ层]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 FunctionPrivate 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 FunctionPrivate Sub Base64CodeTableCreate(Optional ByVal pString As String = conBase64_CodeTableStrng) '功能：根据字符串提供的代码初始化Base64解码/编码码表。
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 SubPrivate Function Bytes2438GetBy2446(ByRef pBytes() As Byte) As Byte() '功能：将素码转换为字节。 Dim tOutBytes() As Byte
Dim tDollops2438() As tpBase64_Dollop2438 Dim tDollops2446() As tpBase64_Dollop2446
Bytes2438GetBy2446 = tOutBytes() End FunctionPrivate Function Bytes2438PutTo2446(ByRef pBytes() As Byte) As Byte() '功能：将字节转换为素码。 Dim tOutBytes() As Byte
Dim tDollops2438() As tpBase64_Dollop2438 Dim tDollops2446() As tpBase64_Dollop2446
BytesGetBy2446 = tOutBytes() End FunctionPrivate Function BytesPutTo2446(ByRef pBytes() As Byte) As tpBase64_Dollop2446() '功能：字节数组转换为2446数组 Dim tOut2446() As tpBase64_Dollop2446 Dim tOut2446_Length As Long
BytesPutTo2446 = tOut2446() End FunctionPrivate 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&
BytesGetBy2438 = tOutBytes() End FunctionPrivate Function BytesPutTo2438(ByRef pBytes() As Byte) As tpBase64_Dollop2438() '功能：字节数组转换为2438数组 Dim tOut2438() As tpBase64_Dollop2438 Dim tOut2438_Length As Long
BytesPutTo2438 = tOut2438() End FunctionPrivate Function Dollops2438GetBy2446(ByRef p2446() As tpBase64_Dollop2446) As tpBase64_Dollop2438() '功能：2446块数组转换为2438块数组 Dim tOut2438() As tpBase64_Dollop2438 Dim tOut2438_Length As Long
For tIndex = 0& To t2446_Length tOut2438(tIndex) = Dollop2438GetBy2446(p2446(tIndex)) Next
Dollops2438GetBy2446 = tOut2438() End FunctionPrivate Function Dollops2438PutTo2446(ByRef p2438() As tpBase64_Dollop2438) As tpBase64_Dollop2446() '功能：2438块数组转换为2446块数组
Dim tOut2446() As tpBase64_Dollop2446 Dim tOut2446_Length 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 FunctionPrivate Function Dollop2438PutTo2446(ByRef p2438 As tpBase64_Dollop2438) As tpBase64_Dollop2446 '功能：2438块转换为2446块 Dim tOut2446 As tpBase64_Dollop2446
Dollop2438PutTo2446 = tOut2446 End FunctionPrivate 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
tOutByte = priBitMoveTable(pByte, pMove) And pConCode
ByteBitMove = tOutByte End FunctionPrivate 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上面这些代码是我自己写的，如果你使用当中发现有任何问题，请及时联系我。
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Base64"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'*************************************************************************************
'Base 64 Encoding class
'
'Author: Wil Johnson
' [email protected]
'
'Version: 1.1
'
'Date: 3/21/2000
'
'Notes:
' This code is for example purposes only, and is provided as-is. While it has
' worked well under limited testing, the current error handling is minimal and
' should be expanded upon before release into a production environment. Please
' report all bugs found to the author for correction, even if you have already
' corrected them yourself.
'
' Again, this code is a rough draft. Feel free to use it, but do so at your own
' risk. These release notes must also remain intact.
'
'*************************************************************************************
Option ExplicitPrivate m_bytIndex(0 To 63) As Byte
Private m_bytReverseIndex(0 To 255) As BytePrivate Const k_bytEqualSign As Byte = 61Private Const k_bytMask1 As Byte = 3 '00000011
Private Const k_bytMask2 As Byte = 15 '00001111
Private Const k_bytMask3 As Byte = 63 '00111111Private Const k_bytMask4 As Byte = 192 '11000000
Private Const k_bytMask5 As Byte = 240 '11110000
Private Const k_bytMask6 As Byte = 252 '11111100Private Const k_bytShift2 As Byte = 4
Private Const k_bytShift4 As Byte = 16
Private Const k_bytShift6 As Byte = 64
Private Const k_lMaxBytesPerLine As Long = 152Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Public Function Encode(ByRef sInput As String) As String
If sInput = "" Then Exit Function
Dim bytTemp() As Byte
bytTemp = StrConv(sInput, vbFromUnicode)
Encode = EncodeArr(bytTemp)
End FunctionPublic Function EncodeFromFile(sFileName As String) As String
On Error GoTo ErrorHandler:
Dim bytFile() As Byte
Dim iFile As Integer
'get new file handle
iFile = FreeFile Open sFileName For Input As #iFile
'size the array to the size of the file
ReDim bytFile(0 To VBA.LOF(iFile) - 1) As Byte
'get everything in the file
Input #iFile, bytFile
Close #iFile
'encode it
EncodeFromFile = EncodeArr(bytFile)
GoTo Done:
ErrorHandler:
EncodeFromFile = ""
Resume Done:Done:
On Error Resume Next
Close #iFile
End Function
On Error GoTo ErrorHandler:
Dim bytWorkspace() As Byte 'array for the "rough draft" of the encoded data
Dim bytResult() As Byte 'array for the "final draft"
Dim bytCrLf(0 To 3) As Byte 'array that will contain vbCrLf, for CopyMemory purposes
Dim lCounter As Long 'counter used to iterate through input bytes
Dim lWorkspaceCounter As Long 'counter used to iterate through workspace bytes
Dim lLineCounter As Long 'counter used when inserting CrLfs
Dim lCompleteLines As Long 'used for calculations when inserting CrLfs
Dim lBytesRemaining As Long 'used to determine how much work is left after coming out of a loop 'pointers
Dim lpWorkSpace As Long 'pointer to bytWorkspace. it's offset will change as bytes are copied out of the array
Dim lpResult As Long 'pointer to bytResult. it's offset will also change
Dim lpCrLf As Long 'pointer to bytCrLf. it is not offset and will not change
'create a workspace larger than we need
'this is to prevent VB from having to allocate memory constantly
If UBound(bytInput) < 1024 Then
ReDim bytWorkspace(LBound(bytInput) To (LBound(bytInput) + 4096)) As Byte
Else
ReDim bytWorkspace(LBound(bytInput) To (UBound(bytInput) * 4)) As Byte
End If
lWorkspaceCounter = LBound(bytWorkspace) 'step through in 3 byte increments
For lCounter = LBound(bytInput) To (UBound(bytInput) - ((UBound(bytInput) Mod 3) + 3)) Step 3
'result set byte 1 = 6 most significant bits of first byte of input set
'bits are right shifted by 2
bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
'result set byte 2 = 2 least significant bits of first byte and 4 most significant bits of second byte of input set
'bits from first byte are left shifted by 4
'bits from second byte are right shifted by 4
bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
'result set byte 3 = 4 least significant bits of second byte and 2 most significant bits of third byte of input set
'bits from second byte are left shifted by 2
'bits from third byte are right shifted by 6
bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex(((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2) + (bytInput(lCounter + 2) \ k_bytShift6))
'result set byte 4 = 6 least significant bits of third byte of input set
'bits from third byte are not shifted at all
bytWorkspace(lWorkspaceCounter + 6) = m_bytIndex(bytInput(lCounter + 2) And k_bytMask3)
lWorkspaceCounter = lWorkspaceCounter + 8
Next lCounter
Select Case (UBound(bytInput) Mod 3):
'for information on how bits are masked and shifted, see above
Case 0:
bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex((bytInput(lCounter) And k_bytMask1) * k_bytShift4)
bytWorkspace(lWorkspaceCounter + 4) = k_bytEqualSign
bytWorkspace(lWorkspaceCounter + 6) = k_bytEqualSign
Case 1:
bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2)
bytWorkspace(lWorkspaceCounter + 6) = k_bytEqualSign Case 2:
bytWorkspace(lWorkspaceCounter) = m_bytIndex((bytInput(lCounter) \ k_bytShift2))
bytWorkspace(lWorkspaceCounter + 2) = m_bytIndex(((bytInput(lCounter) And k_bytMask1) * k_bytShift4) + ((bytInput(lCounter + 1)) \ k_bytShift4))
bytWorkspace(lWorkspaceCounter + 4) = m_bytIndex(((bytInput(lCounter + 1) And k_bytMask2) * k_bytShift2) + ((bytInput(lCounter + 2)) \ k_bytShift6))
bytWorkspace(lWorkspaceCounter + 6) = m_bytIndex(bytInput(lCounter + 2) And k_bytMask3)
End Select lWorkspaceCounter = lWorkspaceCounter + 8 'base64 encoding allows no more than 76 characters per line,
'which translates to 152 bytes since the string is unicode
If lWorkspaceCounter <= k_lMaxBytesPerLine Then
'no need to line wrap.
EncodeArr = Left$(bytWorkspace, InStr(1, bytWorkspace, Chr$(0)) - 1)
'EncodeArr = bytWorkspace
Else
'must wrap lines
'first, populate the CrLf byte array
bytCrLf(0) = 13
bytCrLf(1) = 0
bytCrLf(2) = 10
bytCrLf(3) = 0
'size the end result array
ReDim bytResult(LBound(bytWorkspace) To UBound(bytWorkspace))
'get pointers to the various arrays
lpWorkSpace = VarPtr(bytWorkspace(LBound(bytWorkspace)))
lpResult = VarPtr(bytResult(LBound(bytResult)))
lpCrLf = VarPtr(bytCrLf(LBound(bytCrLf)))
'get count of complete lines
lCompleteLines = Fix(lWorkspaceCounter / k_lMaxBytesPerLine)
For lLineCounter = 0 To lCompleteLines
'copy first line
CopyMemory lpResult, lpWorkSpace, k_lMaxBytesPerLine
'offset the workspace and result pointers by k_lMaxBytesPerLine
lpWorkSpace = lpWorkSpace + k_lMaxBytesPerLine
lpResult = lpResult + k_lMaxBytesPerLine
'copy CrLf to result
CopyMemory lpResult, lpCrLf, 4&
'offset result pointer by another 4 bytes to account for the CrLf
lpResult = lpResult + 4&
Next lLineCounter
'check if there are any remaining bytes in an incomplete line to be copied
lBytesRemaining = lWorkspaceCounter - (lCompleteLines * k_lMaxBytesPerLine)
If lBytesRemaining > 0 Then
'copy remaining bytes to result
CopyMemory lpResult, lpWorkSpace, lBytesRemaining
End If
'no need to resize the result before passing it back to a string,
'since the empty space is made up of null chars that will terminate the
'string automatically.
'CopyMemory StrPtr(EncodeArr), VarPtr(bytResult(LBound(bytResult))), lpResult + lBytesRemaining
EncodeArr = Left$(bytResult, InStr(1, bytResult, Chr$(0)) - 1)
End If
Exit FunctionErrorHandler:
'on error just return an empty array
Erase bytResult
EncodeArr = bytResult
End FunctionPublic Function Decode(sInput As String) As String
If sInput = "" Then Exit Function
Decode = StrConv(DecodeArr(sInput), vbUnicode)
End FunctionPublic Sub DecodeToFile(sInput As String, sFileName As String)
On Error GoTo ErrorHandler:
Dim iFile As Integer
'do not overwrite existing files
If Dir(sFileName) <> "" Then
Err.Raise vbObjectError + 1000, "Base64.DecodeToFile", "File already exists."
GoTo Done:
End If
iFile = FreeFile
Open sFileName For Binary As #iFile
Put #iFile, , DecodeArr(sInput)
Close #iFile
GoTo Done
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Resume Done:
Done:
On Error Resume Next
Close #iFile
End Sub
Public Function DecodeArr(sInput As String) As Byte()
'returns a SBCS byte array
Dim bytInput() As Byte 'base64 encoded string to work with
Dim bytWorkspace() As Byte 'byte array to use as workspace
Dim bytResult() As Byte 'array that result will be copied to
Dim lInputCounter As Long 'iteration counter for input array
Dim lWorkspaceCounter As Long 'iteration counter for workspace array
'get rid of CrLfs, and "="s since they're not required for decoding,
'and place the input in the byte array
bytInput = Replace(Replace(sInput, vbCrLf, ""), "=", "")
'size the workspace
ReDim bytWorkspace(LBound(bytInput) To (UBound(bytInput) * 2)) As Byte
lWorkspaceCounter = LBound(bytWorkspace)
'pass bytes back through index to get original values
For lInputCounter = LBound(bytInput) To UBound(bytInput)
bytInput(lInputCounter) = m_bytReverseIndex(bytInput(lInputCounter))
Next lInputCounter
For lInputCounter = LBound(bytInput) To (UBound(bytInput) - ((UBound(bytInput) Mod 8) + 8)) Step 8
'left shift first input byte by 2 and right shift second input byte by 4
bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
'mask bits 5-8 of second byte, left shift it by 4
'right shift third byte by 2, add it to result of second byte
bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + _
(bytInput(lInputCounter + 4) \ k_bytShift2)
'mask bits 3-8 of third byte, left shift it by 6, add it to fourth byte
bytWorkspace(lWorkspaceCounter + 2) = ((bytInput(lInputCounter + 4) And k_bytMask1) * k_bytShift6) + _
bytInput(lInputCounter + 6)
lWorkspaceCounter = lWorkspaceCounter + 3
Next lInputCounter
'decode any remaining bytes that are not part of a full 4 byte block
Select Case (UBound(bytInput) Mod 8):
Case 3:
'left shift first input byte by 2 and right shift second input byte by 4
bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
Case 5:
'left shift first input byte by 2 and right shift second input byte by 4
bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
'mask bits 5-8 of second byte, left shift it by 4
'right shift third byte by 2, add it to result of second byte
bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + _
(bytInput(lInputCounter + 4) \ k_bytShift2)
lWorkspaceCounter = lWorkspaceCounter + 1
Case 7:
'left shift first input byte by 2 and right shift second input byte by 4
bytWorkspace(lWorkspaceCounter) = (bytInput(lInputCounter) * k_bytShift2) + (bytInput(lInputCounter + 2) \ k_bytShift4)
'mask bits 5-8 of second byte, left shift it by 4
'right shift third byte by 2, add it to result of second byte
bytWorkspace(lWorkspaceCounter + 1) = ((bytInput(lInputCounter + 2) And k_bytMask2) * k_bytShift4) + _
(bytInput(lInputCounter + 4) \ k_bytShift2)
'mask bits 3-8 of third byte, left shift it by 6, add it to fourth byte
bytWorkspace(lWorkspaceCounter + 2) = ((bytInput(lInputCounter + 4) And k_bytMask1) * k_bytShift6) + _
bytInput(lInputCounter + 6)
lWorkspaceCounter = lWorkspaceCounter + 2
End Select
'size the result array
ReDim bytResult(LBound(bytWorkspace) To lWorkspaceCounter) As Byte
'if option base is set to 1 then don't increment this value
If LBound(bytWorkspace) = 0 Then
lWorkspaceCounter = lWorkspaceCounter + 1
End If
'move decoded data to a properly sized array
CopyMemory VarPtr(bytResult(LBound(bytResult))), VarPtr(bytWorkspace(LBound(bytWorkspace))), lWorkspaceCounter
'return
DecodeArr = bytResult
End Function
Private Sub Class_Initialize()
m_bytIndex(0) = 65 'Asc("A")
m_bytIndex(1) = 66 'Asc("B")
m_bytIndex(2) = 67 'Asc("C")
m_bytIndex(3) = 68 'Asc("D")
m_bytIndex(4) = 69 'Asc("E")
m_bytIndex(5) = 70 'Asc("F")
m_bytIndex(6) = 71 'Asc("G")
m_bytIndex(7) = 72 'Asc("H")
m_bytIndex(8) = 73 'Asc("I")
m_bytIndex(9) = 74 'Asc("J")
m_bytIndex(10) = 75 'Asc("K")
m_bytIndex(11) = 76 'Asc("L")
m_bytIndex(12) = 77 'Asc("M")
m_bytIndex(13) = 78 'Asc("N")
m_bytIndex(14) = 79 'Asc("O")
m_bytIndex(15) = 80 'Asc("P")
m_bytIndex(16) = 81 'Asc("Q")
m_bytIndex(17) = 82 'Asc("R")
m_bytIndex(18) = 83 'Asc("S")
m_bytIndex(19) = 84 'Asc("T")
m_bytIndex(20) = 85 'Asc("U")
m_bytIndex(21) = 86 'Asc("V")
m_bytIndex(22) = 87 'Asc("W")
m_bytIndex(23) = 88 'Asc("X")
m_bytIndex(24) = 89 'Asc("Y")
m_bytIndex(25) = 90 'Asc("Z")
m_bytIndex(26) = 97 'Asc("a")
m_bytIndex(27) = 98 'Asc("b")
m_bytIndex(28) = 99 'Asc("c")
m_bytIndex(29) = 100 'Asc("d")
m_bytIndex(30) = 101 'Asc("e")
m_bytIndex(31) = 102 'Asc("f")
m_bytIndex(32) = 103 'Asc("g")
m_bytIndex(33) = 104 'Asc("h")
m_bytIndex(34) = 105 'Asc("i")
m_bytIndex(35) = 106 'Asc("j")
m_bytIndex(36) = 107 'Asc("k")
m_bytIndex(37) = 108 'Asc("l")
m_bytIndex(38) = 109 'Asc("m")
m_bytIndex(39) = 110 'Asc("n")
m_bytIndex(40) = 111 'Asc("o")
m_bytIndex(41) = 112 'Asc("p")
m_bytIndex(42) = 113 'Asc("q")
m_bytIndex(43) = 114 'Asc("r")
m_bytIndex(44) = 115 'Asc("s")
m_bytIndex(45) = 116 'Asc("t")
m_bytIndex(46) = 117 'Asc("u")
m_bytIndex(47) = 118 'Asc("v")
m_bytIndex(48) = 119 'Asc("w")
m_bytIndex(49) = 120 'Asc("x")
m_bytIndex(50) = 121 'Asc("y")
m_bytIndex(51) = 122 'Asc("z")
m_bytIndex(52) = 48 'Asc("0")
m_bytIndex(53) = 49 'Asc("1")
m_bytIndex(54) = 50 'Asc("2")
m_bytIndex(55) = 51 'Asc("3")
m_bytIndex(56) = 52 'Asc("4")
m_bytIndex(57) = 53 'Asc("5")
m_bytIndex(58) = 54 'Asc("6")
m_bytIndex(59) = 55 'Asc("7")
m_bytIndex(60) = 56 'Asc("8")
m_bytIndex(61) = 57 'Asc("9")
m_bytIndex(62) = 43 'Asc("+")
m_bytIndex(63) = 47 'Asc("/")
'
'
'
'
'
'
'太长了 留下EMAIL 把资料发给你
'名称: Base64编码/解码模块
'Name: Base64 Encode & Decode Module'作者: KiteGirl [中国]
'coder: KiteGirl [China]'[定义部]'数据结构Option ExplicitPublic Type tpBase64_Dollop2438 '24Bit(8Bit*3Byte)数据块
btBytes(0 To 2) As Byte
End TypePublic Type tpBase64_Dollop2446 '24Bit(6Bit*4Byte)数据块
btBytes(0 To 3) As Byte
End Type'数据表'priBitMoveTable - 移位缓冲表 [D.R.C]Private priBitMoveTable() As Byte '移位缓冲表
Private priBitMoveTable_CellReady() As Boolean '移位缓冲表标志表
Private priBitMoveTable_Create As Boolean '移位缓冲表创建标志'priEncodeTable - 编码表 [D.C]Private priEncodeTable() As Byte '编码表（素码转Base64）
Private priEncodeTable_Create As Boolean'priDecodeTable - 解码表 [D.C]Private priDecodeTable() As Byte '解码表（Base64转素码）
Private priDecodeTable_Create As Boolean'常量'conBase64_CodeTableStrng 'Base64默认编码表(字符串)Public Const conBase64_CodeTableStrng As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"'conBase64_PatchCode 'Base64默认追加码(Ascii)Public Const conBase64_PatchCode As Byte = 61Private Declare Sub Base64_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pDestination As Any, ByRef pSource As Any, ByVal pLength As Long)'[Ⅰ层]Public Function Base64Decode(ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode) As Byte()
Attribute Base64Decode.VB_Description = "将Byte数组表示的Base64编码Ascii字节数组解码为Byte字节数组，并返回。"
'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() As Byte
Dim tOutBytes_Length As Long
Dim tBytes_Length As Byte
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) Or tSurBytes_Length < 0 Then Exit Function
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) Base64Decode = tOutBytes()
End FunctionPublic Function Base64Encode(ByRef pBytes() As Byte, Optional ByVal pPatchCode As Byte = conBase64_PatchCode) As Byte()
Attribute Base64Encode.VB_Description = "将Byte数组编码为Base64编码的Ascii字节数组，并返回。"
'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() As Byte
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) Or tSurBytes_Length < 0 Then Exit Function
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 Base64Encode = tOutBytes()
End Function
'功能：将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 FunctionPrivate 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 FunctionPrivate 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 SubPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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
'功能：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 FunctionPrivate 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 FunctionPrivate 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 FunctionPrivate 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上面这些代码是我自己写的，如果你使用当中发现有任何问题，请及时联系我。