特定字符集的 Excel VBA 解码 URL（即 euc-kr）答案

【问题标题】：Excel VBA decode url for specific charset (i.e. euc-kr)特定字符集的 Excel VBA 解码 URL（即 euc-kr）
【发布时间】：2021-09-03 14:25:09
【问题描述】：

Excel VBA 中有没有一种方法可以通过指定字符集来解码 url？我对我的计算机没有管理员权限，这意味着我无法安装外部软件包，因此我需要一个针对 Excel VBA（或本机环境）的独立解决方案。

我找到了一个链接here 来解码一个url（下面的代码供参考）；但是，它不适用于解码为韩文字符。我收到以下错误：运行时错误“-2147352319 (80020101)”对象“JScriptTypeInfo”的“解码”方法失败。

我试图为 Excel VBA 找到解决方案没有成功。（我运行的是 Windows 10；Microsoft Excel 365，版本 2107；添加了韩语语言包；区域设置 -- 非 unicode 程序的语言：韩语（韩国）。

这是正确结果的示例（使用 charset 'Korean (euc-kr)' here 正确解码/编码）：

编码：%28%C1%D6%29%B7%B9%B0%ED%C4%DA%B8%AE%BE%C6
使用“euc-kr”解码：(주)레고코리아

以下代码参考：

Sub Testing()
Debug.Print UriDecode("%28%C1%D6%29%B7%B9%B0%ED%C4%DA%B8%AE%BE%C6")
End Sub


Function UriDecode(strText As String)
Static objHtmlFile As Object
If objHtmlfile Is Nothing Then
    Set objHtmlfile = CreateObject("htmlfile")
    objHtmlfile.parentWindow.execScript "function decode(s) {return decodeURIComponent(s)}", "jscript"
End If
UriDecode = objHtmlfile.parentWindow.decode(strText)
End Function

【问题讨论】：

标签： excel vba character-encoding urldecode

【解决方案1】：

设法拼凑起来：

Sub Testing()
    ActiveSheet.Range("A1").Value = _
      ToKr("http://google.com?q=%28%C1%D6%29%B7%B9%B0%ED%C4%DA%B8%AE%BE%C6")
End Sub

Function ToKr(str As String) As String
    With CreateObject("ADODB.Stream")
        .Type = 1 'adTypeBinary
        .Open
        .write URLToBytes(str)
        .Position = 0
        .Type = 2 'adTypeText
        .Charset = "euc-kr"
        ToKr = .readtext() 'default is read all
    End With
End Function

Public Function URLToByteArray(EncodedURL As String) As Byte()
    Dim i As Long, sTmp As String
    Dim col As New Collection, arrbyte() As Byte
    i = 1
    Do While i <= Len(EncodedURL) 'fill the collection
        sTmp = Mid(EncodedURL, i, 1)
        sTmp = Replace(sTmp, "+", " ")
        If sTmp = "%" And Len(EncodedURL) + 1 > i + 2 Then '%-encoded?
            sTmp = Mid(EncodedURL, i + 1, 2)
            col.Add CByte("&H" & sTmp)
            i = i + 3 'spent 3 characters...
        Else
            col.Add CByte(Asc(sTmp))
            i = i + 1
        End If
    Loop
    ReDim arrbyte(col.Count - 1) 'fill the byte array from the collection
    For i = 1 To col.Count
        arrbyte(i - 1) = col(i)
    Next i
    URLToByteArray = arrbyte
End Function

输出：

【讨论】：

效果很好！谢谢你。我也使用相同的模式去另一个方向。