Function BytesToBstr(ByRef arrBody() As Byte, ByVal CodeBase As String) As String'- ------------------------------------------- -
' 函数说明:字节数组转换成Unicode字符串(BSTR)
'- ------------------------------------------- -
Dim objStream As Object
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary=1 adTypeText=2
objStream.Mode = 3 'adModeRead=1 adModeWrite=2 adModeReadWrit=3 adModeUnknown=0
objStream.Open
objStream.Write arrBody
objStream.Position = 0
objStream.Type = 2 'adTypeBinary=1 adTypeText=2
objStream.Charset = CodeBase
BytesToBstr = objStream.ReadText
objStream.Close
Set objStream = Nothing
End Function
Function BytesToBytesNoBom(ByRef arrBody() As Byte, ByVal SCodeBase As String, ByVal DCodeBase As String) As Byte()
'- ------------------------------------------- -
' 函数说明:不同编码的字节数组转换
'- ------------------------------------------- -
Dim objStream As Object
Dim SText$, Dtext$
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 1 'adTypeBinary=1 adTypeText=2
objStream.Mode = 3 'adModeRead=1 adModeWrite=2 adModeReadWrit=3 adModeUnknown=0
objStream.Open
objStream.Write arrBody
objStream.Position = 0
objStream.Type = 2 'adTypeText = 2
objStream.Charset = SCodeBase
SText = objStream.ReadText '读取文本到sCode(Unicode)
objStream.Position = 0 ' 这只是定位到文件头
objStream.SetEOS 'Position=0,更新 EOS 属性的值。使EOS的位置为0(也就是把结尾设成开头的位置)
objStream.Type = 2 'adTypeText = 2
objStream.Charset = DCodeBase '指定输出编码
objStream.WriteText SText '写入文本数据到Adodb.Stream
'objStream.SaveToFile ThisWorkbook.Path & Application.PathSeparator & "out.bin", 2 '输出成文件
objStream.Position = 0 '切换type之前,要先重置指针为0
objStream.Type = 1 'adTypeBinary=1 adTypeText=2
If InStr(1, DCodeBase, "utf-8", vbTextCompare) > 0 Then '去掉BOM
objStream.Position = 3
ElseIf InStr(1, DCodeBase, "unicode", vbTextCompare) > 0 Then
objStream.Position = 2
End If
BytesToBytesNoBom = objStream.Read
objStream.Close
Set objStream = Nothing
End Function
Public Function Base64Encode(varIn As Variant, CodeBase As String) As String
'- ------------------------------------------- -
' 函数说明:BASE64编码
'- ------------------------------------------- -
Dim adoStream As Object
Dim xmlDoc As Object
Dim xmlNode As Object
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = CodeBase '文本编码
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
Public Function Base64Decode(varIn As Variant, CodeBase As String, Optional ByVal ReturnValueType As VbVarType = vbString) As Byte()
'- ------------------------------------------- -
' 函数说明:BASE64解码
'- ------------------------------------------- -
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 = CodeBase '文本的编码
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