拍拍尘土

'* ************************************** *
'* 模块名称：modBase64.bas
'* 模块功能：BASE64编码和解码函数
'* 作者：lyserver
'* ************************************** *

Option Explicit

'- ------------------------------------------- -
' 函数说明：BASE64编码
'- ------------------------------------------- -
Public Function Base64Encode(varIn As Variant) As String
         Dim adoStream As Object
         Dim xmlDoc As Object
         Dim xmlNode As Object
        
         Set adoStream = CreateObject("ADODB.Stream")
         adoStream.Charset = "gb2312"
         If VarType(varIn) = vbString Then
                adoStream.Type = 2 'adTypeText
                adoStream.Open
                adoStream.WriteText varIn
         ElseIf VarType(varIn) = vbByte Or vbArray Then
                adoStream.Type = 1 'adTypeBinary
                adoStream.Open
                adoStream.Write varIn
         Else
                Exit Function
         End If
         adoStream.Position = 0
         adoStream.Type = 1 'adTypeBinary
        
         Set xmlDoc = CreateObject("MSXML2.DOMDocument")
         Set xmlNode = xmlDoc.createElement("MyNode")
         xmlNode.dataType = "bin.base64"
         xmlNode.nodeTypedValue = adoStream.Read
         Base64Encode = xmlNode.Text
         adoStream.Close
End Function

'- ------------------------------------------- -
' 函数说明：BASE64解码
'- ------------------------------------------- -
Public Function Base64Decode(varIn As Variant, Optional ByVal ReturnValueType As VbVarType = vbString) As Byte()
         Dim adoStream As Object
         Dim xmlDoc As Object
         Dim xmlNode As Object
        
         Set xmlDoc = CreateObject("MSXML2.DOMDocument")
         Set xmlNode = xmlDoc.createElement("MyNode")
         xmlNode.dataType = "bin.base64"
         If VarType(varIn) = vbString Then
                xmlNode.Text = Replace(varIn, vbCrLf, "")
         ElseIf VarType(varIn) = vbByte Or vbArray Then
                xmlNode.Text = Replace(StrConv(varIn, vbUnicode), vbCrLf, "")
         Else
                Exit Function
         End If
        
         Set adoStream = CreateObject("ADODB.Stream")
         adoStream.Charset = "gb2312"
         adoStream.Type = 1 'adTypeBinary
         adoStream.Open
         adoStream.Write xmlNode.nodeTypedValue
         adoStream.Position = 0
         If ReturnValueType = vbString Then
                adoStream.Type = 2 'adTypeText
                Base64Decode = adoStream.ReadText
         Else
                Base64Decode = adoStream.Read
         End If
         adoStream.Close
End Function