Attribute VB_Name = "modBase64"
'名称: Base64编码/解码模块
'Name: Base64 Encode & Decode Module
'作者: KiteGirl [中国]
'Coder: KiteGirl [China]
'数据结构
Option Explicit
Public Type tpBase64_Dollop2438 '24Bit(8Bit*3Byte)数据块
btBytes(0 To 2) As Byte
End Type
Public 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 = 61
Private 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 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) 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 10&
tBytesIndex = tBytes_Length - tIndex
tPatchNumber = tPatchNumber + ((pBytes(tBytesIndex) = pPatchCode) And 1&)
Next
tSurBytes_Length = tBytes_Length - tPatchNumber
tDesBytes_Length = (tSurBytes_Length * 3&) \ 4&
ReDim Preserve tOutBytes(tDesBytes_Length)
Base64Decode = tOutBytes()
End Function
Public 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
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
发表于 @ 2007年06月22日 08:35:00|评论(loading...)|编辑