[问题求助] VBS如何解码base64字符串

Demon

UTF-8编码的“批处理之家”经过base64编码以后是“5om55aSE55CG5LmL5a62”，怎样从“5om55aSE55CG5LmL5a62”还原成“批处理之家”？

Spring

网上早有人写好了，搜索一下就能得到：

WScript.Echo  utf8to16(Base64Decode("5om55aSE55CG5LmL5a62"))

Function utf8to16(str)
    Dim out, i, len1, c, t
    Dim char2, char3
    out = ""
    len1 = Len(str)
    i = 0
    While (i < len1)
        c = Asc(Mid(str, i + 1, 1))
        i = i + 1
        t = c \ 16
        If t >= 0 And t <= 7 Then
            out = out + Mid(str, i, 1)
        ElseIf t = 12 Or t = 13 Then
            char2 = Asc(Mid(str, i + 1, 1))
            i = i + 1
            out = out + Chr(((c And 31) * 64) Or (char2 And 31))
        ElseIf t = 14 Then
            char2 = Asc(Mid(str, i + 1, 1))
            i = i + 1
            char3 = Asc(Mid(str, i + 1, 1))
            i = i + 1
            out = out + ChrW(((c And 15) * 4096) Or ((char2 And 63) * 64) Or ((char3 And 63)))
        End If
    Wend
    utf8to16 = out
End Function

' Decodes a base-64 encoded string (BSTR type).
' 1999 - 2004 Antonin Foller, http://www.motobit.com
' 1.01 - solves problem with Access And 'Compare Database' (InStr)
Function Base64Decode(ByVal base64String)
  'rfc1521
  '1999 Antonin Foller, Motobit Software, http://Motobit.cz
  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
  Dim dataLength, sOut, groupBegin
  
  'remove white spaces, If any
  base64String = Replace(base64String, vbCrLf, "")
  base64String = Replace(base64String, vbTab, "")
  base64String = Replace(base64String, " ", "")
  
  'The source must consists from groups with Len of 4 chars
  dataLength = Len(base64String)
  If dataLength Mod 4 <> 0 Then
    Err.Raise 1, "Base64Decode", "Bad Base64 string."
    Exit Function
  End If

  
  ' Now decode each group:
  For groupBegin = 1 To dataLength Step 4
    Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut
    ' Each data group encodes up To 3 actual bytes.
    numDataBytes = 3
    nGroup = 0

    For CharCounter = 0 To 3
      ' Convert each character into 6 bits of data, And add it To
      ' an integer For temporary storage.  If a character is a '=', there
      ' is one fewer data byte.  (There can only be a maximum of 2 '=' In
      ' the whole string.)

      thisChar = Mid(base64String, groupBegin + CharCounter, 1)

      If thisChar = "=" Then
        numDataBytes = numDataBytes - 1
        thisData = 0
      Else
        thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1
      End If
      If thisData = -1 Then
        Err.Raise 2, "Base64Decode", "Bad character In Base64 string."
        Exit Function
      End If

      nGroup = 64 * nGroup + thisData
    Next
    
    'Hex splits the long To 6 groups with 4 bits
    nGroup = Hex(nGroup)
    
    'Add leading zeros
    nGroup = String(6 - Len(nGroup), "0") & nGroup
    
    'Convert the 3 byte hex integer (6 chars) To 3 characters
    pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _
      Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _
      Chr(CByte("&H" & Mid(nGroup, 5, 2)))
    
    'add numDataBytes characters To out string
    sOut = sOut & Left(pOut, numDataBytes)
  Next

  Base64Decode = sOut
End Function
复制代码

Demon

网上早有人写好了，搜索一下就能得到：
WScript.Echo  utf8to16(Base64Decode("5om55aSE55CG5LmL5a62"))

Function utf8to16(str)
    Dim out, i, len1, c, t
    Dim char2, char3
    out = ""
    len1 = ...
Spring 发表于 2011-6-4 14:05

复制粘贴之前起码验证一下吧，上面代码输出“???????????????”

mglouis

拿来主义啊................

zqz0012005

WScript.Echo binaryToText(base64ToBin("5om55aSE55CG5LmL5a62"), "utf-8")

Demon

WScript.Echo binaryToText(base64ToBin("5om55aSE55CG5LmL5a62"), "utf-8")
zqz0012005 发表于 2011-6-27 21:51

WScript.Echo "批处理之家"
复制代码

batman

6# Demon
五楼不是演示解密的。。。

dahual

主要还是编码的问题。
通过解决这个问题，让我觉得字节是最完美的。

'参考链接：
'http://maclife.net/tools/base64/
'http://blog.csdn.net/zym_123456/archive/2008/03/30/2230695.aspx
Option Explicit

MsgBox Base64ToText_Utf8Encode("5om55aSE55CG5LmL5a62")

'Base64ToText_utf8Encode
Function Base64ToText_Utf8Encode(s)
	Dim i
	Dim bArr,bRet
	ReDim bArr(Len(s)-1)
	
	For i=1 To Len(s)
		bArr(i-1)=Asc(Mid(s,i,1))
	Next
	bRet=Base64_Decode(bArr)
	Base64ToText_utf8Encode=Utf8ToUnicode(bRet)
End Function

'Utf8ToUnicode
Function Utf8ToUnicode(src)
	Dim IsAsc
	Dim utfLen
	utfLen = -1
	
	On Error Resume Next
	utfLen = UBound(src)-LBound(src)+1
	If utfLen = -1 Then Exit Function
	On Error GoTo 0
	
	Dim i,j,k,N
	Dim B,cnt
	ReDim Buf(utfLen)
	i = 1
	j = 0
	Do While i <= utfLen
		B = src(i-1)
		If (B And &HFC) = &HFC Then
			cnt = 6
		ElseIf (B And &HF8) = &HF8 Then
			cnt = 5
		ElseIf (B And &HF0) = &HF0 Then
			cnt = 4
		ElseIf (B And &HE0) = &HE0 Then
			cnt = 3
		ElseIf (B And &HC0) = &HC0 Then
			cnt = 2
		Else
			cnt = 1
		End If
		If i + cnt - 1 > utfLen Then
			Buf(j) = "?"
			Exit Do
		End If
		Select Case cnt
			Case 2
				N = B And &H1F
			Case 3
				N = B And &HF
			Case 4
				N = B And &H7
			Case 5
				N = B And &H3
			Case 6
				N = B And &H1
			Case Else
				Buf(j) = Chr(B)
				IsAsc=True
		End Select
		If IsAsc=False Then
			For k = 1 To cnt - 1
				B = src(i+k-1)
				N = N * &H40 + (B And &H3F)
			Next
			Buf(j) = ChrW(N)
		End If
		i = i + cnt
		j = j + 1
		IsAsc=False
	Loop
	Utf8ToUnicode = Join(Buf, "")
End Function

'Base64解码函数
Public Function Base64_Decode(bytInText)
    Dim Base64DecodeTable(122)
    Dim lngInTextLen, i
    Dim bytDecode, lngDecodeLen
    
    Base64_Decode = Chr(0)  '初始化函数返回值
    
    If LBound(bytInText) <> 0 Then Exit Function  'bytInText数组下标不从零开始则出错返回
    
    lngInTextLen = UBound(bytInText) - LBound(bytInText) + 1  '计算bytInText数组长度
    If lngInTextLen Mod 4 <> 0 Then Exit Function  '输入编码不是4的倍数则出错返回
    
    For i = 1 To 122  '初始化Base64解码表
        Select Case True
        Case i=43  '+
            Base64DecodeTable(i) = 62
        Case i=47  '/
            Base64DecodeTable(i) = 63
        Case i>=48 And i<=57  '0 - 9
            Base64DecodeTable(i) = 52 + (i - 48)
        Case i>=65 And i<=90  'A - Z
            Base64DecodeTable(i) = 0 + (i - 65)
        Case i>=97 And i<=122  'a - z
            Base64DecodeTable(i) = 26 + (i - 97)
        Case Else
            Base64DecodeTable(i) = 255
        End Select
    Next
    lngDecodeLen = lngInTextLen / 4 * 3  '求解码后的最大长度
    ReDim bytDecode(lngDecodeLen - 1)  '重新定义解码缓冲区
    'MsgBox "解码后的最大长度为：" & lngDecodeLen
    
    lngDecodeLen = 0  '初始化解码长度
    
    For i = 0 To lngInTextLen - 1 Step 4
        bytDecode(lngDecodeLen) = (Base64DecodeTable(bytInText(i)) * (2 ^ 2)) Or ((Base64DecodeTable(bytInText(i + 1)) And &H30) \ (2 ^ 4))
        bytDecode(lngDecodeLen + 1) = ((Base64DecodeTable(bytInText(i + 1)) And &HF) * (2 ^ 4)) Or ((Base64DecodeTable(bytInText(i + 2)) And &H3C) \ (2 ^ 2))
        bytDecode(lngDecodeLen + 2) = ((Base64DecodeTable(bytInText(i + 2)) And &H3) * (2 ^ 6)) Or Base64DecodeTable(bytInText(i + 3))
        lngDecodeLen = lngDecodeLen + 3
    Next
    
    If bytInText(lngInTextLen - 1) = &H3D Then  '判断最后两个字节的情况,求解码后的实际长度
        If bytInText(lngInTextLen - 2) = &H3D Then
            lngDecodeLen = lngDecodeLen - 2  '最后两个字节为"="
        Else
            lngDecodeLen = lngDecodeLen - 1  '最后一个字节为"="
        End If
        bytDecode(lngDecodeLen) = 0  '在实际长度的后一个字节放个结束符
    End If
    'MsgBox "解码后的实际长度为：" & lngDecodeLen
    
    Base64_Decode = bytDecode
End Function
复制代码

powerbat

幸好我在verybat收藏了zqz版主的binaryToText()、base64ToBin()、字符编码转换等很多常用函数。

既然版主没帖出来，我也不能越俎代庖。

HAT

敝帚自珍的思想，要不得。

broly

9# powerbat

powerbat把代码都贴了吧，最好在“VBS原创&转载区”，让大家都学习学习。

yu2n

正好翻出来一个有意思的点 utf8 bom…

Option Explicit

WScript.Echo base64utf8("5om55aSE55CG5LmL5a62", False) & vbCrLf & _
	base64utf8("批处理之家", True)

'************************************************************************
'字符串 Base64 编码、解码 (utf-8)
'************************************************************************
Function base64utf8(ByVal sText, ByVal bAsEncodeDecode)
	Dim oStream, oXML, oNode
	On Error Resume Next
	Set oStream = CreateObject("ADODB.Stream")
	Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
	Set oNode = oXML.CreateElement("base64")
	oNode.DataType = "bin.base64"
	base64utf8 = ""
	If bAsEncodeDecode Then
		oStream.Type = 2	'adTypeText = 2
		oStream.Charset = "utf-8"
		oStream.Open
		oStream.WriteText sText
		oStream.Position = 0
		oStream.Type = 1	'adTypeBinary = 1
		oStream.Position = 0
		oNode.nodeTypedValue = oStream.Read
		If Err.Number = 0 Then
			base64utf8 = oNode.Text	'移除 utf-8 文件的 BMO头 efbbbf。base64_decode('77u/')
			If Left(base64utf8, 4) = "77u/" Then base64utf8 = Mid(base64utf8,5) 
		End If
	Else
		oStream.Type = 1	'adTypeBinary = 1
		oStream.Open
		oNode.Text = sText
		oStream.Write oNode.nodeTypedValue
		oStream.Position = 0
		oStream.Type = 2	'adTypeText = 2
		oStream.Charset = "utf-8"
		If Err.Number = 0 Then base64utf8 = oStream.ReadText
	End If
	Set oStream = Nothing
	Set oNode = Nothing
	Set oXML = Nothing
End Function
复制代码

结果如下：

---------------------------
Windows Script Host
---------------------------
批处理之家

5om55aSE55CG5LmL5a62
---------------------------
确定   
---------------------------
复制代码