如何在 Excel VBA 中对字符串进行 URL 编码？答案

【问题标题】：How can I URL encode a string in Excel VBA?如何在 Excel VBA 中对字符串进行 URL 编码？
【发布时间】：2010-09-18 02:32:11
【问题描述】：

是否有内置方法可以在 Excel VBA 中对字符串进行 URL 编码，或者我是否需要手动滚动此功能？

【问题讨论】：

标签： excel vba url encoding urlencode

【解决方案1】：

接受的答案的代码在 Access 2013 中因 Unicode 错误而停止，因此我为自己编写了一个具有高可读性的函数，该函数应遵循 RFC 3986 根据Davis Peixoto，并在各种环境中造成最小的麻烦。

注意：必须先替换百分号本身，否则它将对任何先前编码的字符进行双重编码。添加了用 + 替换空格，不是为了符合 RFC 3986，而是为了提供不会因格式化而中断的链接。它是可选的。

Public Function URLEncode(str As Variant) As String
    Dim i As Integer, sChar() As String, sPerc() As String
    sChar = Split("%|!|*|'|(|)|;|:|@|&|=|+|$|,|/|?|#|[|]| ", "|")
    sPerc = Split("%25 %21 %2A %27 %28 %29 %3B %3A %40 %26 %3D %2B %24 %2C %2F %3F %23 %5B %5D +", " ")
    URLEncode = Nz(str)
    For i = 0 To 19
        URLEncode = Replace(URLEncode, sChar(i), sPerc(i))
    Next i
End Function

【讨论】：

【解决方案2】：

以上支持UTF8的版本：

Private Const CP_UTF8 = 65001

#If VBA7 Then
  Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#Else
  Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#End If

Public Function UTF16To8(ByVal UTF16 As String) As String
Dim sBuffer As String
Dim lLength As Long
If UTF16 <> "" Then
    #If VBA7 Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, CLngPtr(StrPtr(UTF16)), -1, 0, 0, 0, 0)
    #Else
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
    #End If
    sBuffer = Space$(lLength)
    #If VBA7 Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, CLngPtr(StrPtr(UTF16)), -1, CLngPtr(StrPtr(sBuffer)), LenB(sBuffer), 0, 0)
    #Else
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), LenB(sBuffer), 0, 0)
    #End If
    sBuffer = StrConv(sBuffer, vbUnicode)
    UTF16To8 = Left$(sBuffer, lLength - 1)
Else
    UTF16To8 = ""
End If
End Function

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False, _
   Optional UTF8Encode As Boolean = True _
) As String

Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
Dim StringLen As Long: StringLen = Len(StringValCopy)

If StringLen > 0 Then
    ReDim Result(StringLen) As String
    Dim I As Long, CharCode As Integer
    Dim Char As String, Space As String

  If SpaceAsPlus Then Space = "+" Else Space = "%20"

  For I = 1 To StringLen
    Char = Mid$(StringValCopy, I, 1)
    CharCode = Asc(Char)
    Select Case CharCode
      Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
        Result(I) = Char
      Case 32
        Result(I) = Space
      Case 0 To 15
        Result(I) = "%0" & Hex(CharCode)
      Case Else
        Result(I) = "%" & Hex(CharCode)
    End Select
  Next I
  URLEncode = Join(Result, "")

End If
End Function

享受吧！

【讨论】：

在根据票数可能会上升或下降的答案中提及“上述”是没有用的。
现在它需要带有PtrSafe 和LongPtr 的VBA7 标头。

【解决方案3】：

为了更新这一点，从 Excel 2013 开始，现在有一种使用工作表函数 ENCODEURL 对 URL 进行编码的内置方法。

要在您的 VBA 代码中使用它，您只需调用

EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

Documentation

【讨论】：

当我不得不在字段中使用连续逗号对 csv 数据进行编码时，它失败了。必须在答案中使用上述 utf8 版本
@SalmanSiddique 很高兴知道这些限制。可能值得一提的是您使用的哪个 utf8 版本不止一个
Application.WorksheetFunction.EncodeUrl(myString) 完美地满足了我的需求 - 希望这个答案将得到足够的支持以取代以前的超级旧版本
@jamheadart 公平地说，这个答案链接到已接受答案的第一行
这很公平。我没注意到。我看到了大量的代码和日期，并认为下面会有更好的答案！

【解决方案4】：

VBA-tools 库有一个功能：

http://vba-tools.github.io/VBA-Web/docs/#/WebHelpers/UrlEncode

它的工作方式似乎类似于 JavaScript 中的encodeURIComponent()。

【讨论】：

【解决方案5】：

不，没有任何内置功能（直到 Excel 2013 - see this answer）。

此答案中有URLEncode() 的三个版本。

支持 UTF-8 的函数。 您可能应该使用这个（或 Tom 的 the alternative implementation）以符合现代要求。
出于参考和教育目的，不支持 UTF-8 的两个函数：
- 在第三方网站上找到的，按原样包含在内。（这是答案的第一个版本）
- 一个优化版本，由我编写

支持 UTF-8 编码并基于 ADODB.Stream 的变体（在您的项目中包含对“Microsoft ActiveX 数据对象”库的最新版本的引用）：

Public Function URLEncode( _
   ByVal StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String
  Dim bytes() As Byte, b As Byte, i As Integer, space As String

  If SpaceAsPlus Then space = "+" Else space = "%20"

  If Len(StringVal) > 0 Then
    With New ADODB.Stream
      .Mode = adModeReadWrite
      .Type = adTypeText
      .Charset = "UTF-8"
      .Open
      .WriteText StringVal
      .Position = 0
      .Type = adTypeBinary
      .Position = 3 ' skip BOM
      bytes = .Read
    End With

    ReDim result(UBound(bytes)) As String

    For i = UBound(bytes) To 0 Step -1
      b = bytes(i)
      Select Case b
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Chr(b)
        Case 32
          result(i) = space
        Case 0 To 15
          result(i) = "%0" & Hex(b)
        Case Else
          result(i) = "%" & Hex(b)
      End Select
    Next i

    URLEncode = Join(result, "")
  End If
End Function

这个函数是found on freevbcode.com:

Public Function URLEncode( _
   StringToEncode As String, _
   Optional UsePlusRatherThanHexForSpace As Boolean = False _
) As String

  Dim TempAns As String
  Dim CurChr As Integer
  CurChr = 1

  Do Until CurChr - 1 = Len(StringToEncode)
    Select Case Asc(Mid(StringToEncode, CurChr, 1))
      Case 48 To 57, 65 To 90, 97 To 122
        TempAns = TempAns & Mid(StringToEncode, CurChr, 1)
      Case 32
        If UsePlusRatherThanHexForSpace = True Then
          TempAns = TempAns & "+"
        Else
          TempAns = TempAns & "%" & Hex(32)
        End If
      Case Else
        TempAns = TempAns & "%" & _
          Right("0" & Hex(Asc(Mid(StringToEncode, _
          CurChr, 1))), 2)
    End Select

    CurChr = CurChr + 1
  Loop

  URLEncode = TempAns
End Function

我已经纠正了其中的一个小错误。

我会使用上述更高效（约 2 倍）的版本：

Public Function URLEncode( _
   StringVal As String, _
   Optional SpaceAsPlus As Boolean = False _
) As String

  Dim StringLen As Long: StringLen = Len(StringVal)

  If StringLen > 0 Then
    ReDim result(StringLen) As String
    Dim i As Long, CharCode As Integer
    Dim Char As String, Space As String

    If SpaceAsPlus Then Space = "+" Else Space = "%20"

    For i = 1 To StringLen
      Char = Mid$(StringVal, i, 1)
      CharCode = Asc(Char)
      Select Case CharCode
        Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
          result(i) = Char
        Case 32
          result(i) = Space
        Case 0 To 15
          result(i) = "%0" & Hex(CharCode)
        Case Else
          result(i) = "%" & Hex(CharCode)
      End Select
    Next i
    URLEncode = Join(result, "")
  End If
End Function

请注意，这两个函数都不支持 UTF-8 编码。

【讨论】：

我使用了您的“更高效（约 2 倍）的版本”，效果很好！谢谢。
@Chris 谢谢。 :) 请注意，如果您使用 ADODB.Stream 对象，您可能可以制作一个兼容 UTF-8 的版本，它可以进行必要的字符串转换。如何使用 VBA 或 VBScript 生成 UTF-8 的示例遍布 Internet。
如果性能是一个问题 - 考虑重构以使用“替换”通过循环整数 0 到 255 并执行以下操作：案例 0 到 36、38 到 47、58 到 64、91 到 96， 123 到 255 str_Input = Replace(str_Input, Chr(int_char_num), "%" & Right("0" & Hex(255), 2))
这实际上会适得其反。 VB 字符串是不可变的，对一个字符串执行 255 次替换会为迭代的每一步分配一个新的完整字符串。就空间和内存而言，这肯定比将字母分配给预先分配的数组更浪费。
此代码将在 Access 2013 中出现 Unicode 错误时停止，因为它同时处理太多和太少的字符。

【解决方案6】：

从 Office 2013 开始使用这个内置函数here。

如果在办公室 2013 之前

Function encodeURL(str As String)
Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"

ScriptEngine.AddCode "function encode(str) {return encodeURIComponent(str);}"
Dim encoded As String


encoded = ScriptEngine.Run("encode", str)
encodeURL = encoded
End Function

添加 Microsoft Script Control 作为参考，您就完成了。

与上一篇相同，只是完成了功能..works！

【讨论】：

完成。好的，我不知道我可以编辑，不幸的是，你没有获得编辑积分！
仅供参考，我尝试更新其他帖子，但我的编辑得到了审核！例如。 Micha 在 18 小时前对此进行了评论：拒绝此编辑不正确或试图回复或评论现有帖子。 alex2410 在 18 小时前对此进行了评论：拒绝此编辑不正确或试图回复或评论现有帖子。 bansi 在 18 小时前对此进行了评论：拒绝此编辑不正确或试图回复或评论现有帖子。 -
ScriptControl 不适用于 64 位 Office 版本，请检查 solution via htmlfile ActiveX 和 workaround getting ScriptControl to work with Excel x64。

【解决方案7】：

与 WorksheetFunction.EncodeUrl 相同，支持 UTF-8：

Public Function EncodeURL(url As String) As String
  Dim buffer As String, i As Long, c As Long, n As Long
  buffer = String$(Len(url) * 12, "%")

  For i = 1 To Len(url)
    c = AscW(Mid$(url, i, 1)) And 65535

    Select Case c
      Case 48 To 57, 65 To 90, 97 To 122, 45, 46, 95  ' Unescaped 0-9A-Za-z-._ '
        n = n + 1
        Mid$(buffer, n) = ChrW(c)
      Case Is <= 127            ' Escaped UTF-8 1 bytes U+0000 to U+007F '
        n = n + 3
        Mid$(buffer, n - 1) = Right$(Hex$(256 + c), 2)
      Case Is <= 2047           ' Escaped UTF-8 2 bytes U+0080 to U+07FF '
        n = n + 6
        Mid$(buffer, n - 4) = Hex$(192 + (c \ 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
      Case 55296 To 57343       ' Escaped UTF-8 4 bytes U+010000 to U+10FFFF '
        i = i + 1
        c = 65536 + (c Mod 1024) * 1024 + (AscW(Mid$(url, i, 1)) And 1023)
        n = n + 12
        Mid$(buffer, n - 10) = Hex$(240 + (c \ 262144))
        Mid$(buffer, n - 7) = Hex$(128 + ((c \ 4096) Mod 64))
        Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
      Case Else                 ' Escaped UTF-8 3 bytes U+0800 to U+FFFF '
        n = n + 9
        Mid$(buffer, n - 7) = Hex$(224 + (c \ 4096))
        Mid$(buffer, n - 4) = Hex$(128 + ((c \ 64) Mod 64))
        Mid$(buffer, n - 1) = Hex$(128 + (c Mod 64))
    End Select
  Next

  EncodeURL = Left$(buffer, n)
End Function

【讨论】：

【解决方案8】：

这里的解决方案都不适用于我，但这很可能是由于我缺乏 VBA 经验。也可能是因为我只是复制并粘贴了上面的一些函数，不知道使它们在 VBA for applications 环境中工作可能需要的细节。

我的需要只是使用包含一些挪威语言特殊字符的 url 发送 xmlhttp 请求。上面的一些解决方案甚至对冒号进行了编码，这使得网址不适合我的需要。

然后我决定编写自己的 URLEncode 函数。它不使用更聪明的编程，例如来自@ndd 和@Tom 的编程。我不是一个很有经验的程序员，但我必须尽快完成这项工作。

我意识到问题在于我的服务器不接受 UTF-16 编码，因此我必须编写一个将 UTF-16 转换为 UTF-8 的函数。 here 和 here 找到了一个很好的信息来源。

我没有对它进行广泛的测试，以检查它是否适用于具有更高 unicode 值并且会产生超过 2 个字节的 utf-8 字符的字符的 url。我并不是说它会解码所有需要解码的东西（但很容易修改以在select case 语句中包含/排除字符），也不是说它可以处理更高的字符，因为我还没有完全测试过。但我分享代码是因为它可能对试图理解问题的人有所帮助。

欢迎任何cmets。

Public Function URL_Encode(ByVal st As String) As String

    Dim eachbyte() As Byte
    Dim i, j As Integer 
    Dim encodeurl As String
    encodeurl = "" 

    eachbyte() = StrConv(st, vbFromUnicode)

    For i = 0 To UBound(eachbyte)

        Select Case eachbyte(i)
        Case 0
        Case 32
            encodeurl = encodeurl & "%20"

        ' I am not encoding the lower parts, not necessary for me
        Case 1 To 127
            encodeurl = encodeurl & Chr(eachbyte(i))
        Case Else

            Dim myarr() As Byte
            myarr = utf16toutf8(eachbyte(i))
            For j = LBound(myarr) To UBound(myarr) - 1
                encodeurl = encodeurl & "%" & Hex(myarr(j))
            Next j
        End Select
    Next i
    URL_Encode = encodeurl 
End Function

Public Function utf16toutf8(ByVal thechars As Variant) As Variant
    Dim numbytes As Integer
    Dim byte1 As Byte
    Dim byte2 As Byte
    Dim byte3 As Byte
    Dim byte4 As Byte
    Dim byte5 As Byte 
    Dim i As Integer  
    Dim temp As Variant
    Dim stri As String

    byte1 = 0
    byte2 = byte3 = byte4 = byte5 = 128

    ' Test to see how many bytes the utf-8 char will need
    Select Case thechars
        Case 0 To 127
            numbytes = 1
        Case 128 To 2047
            numbytes = 2
        Case 2048 To 65535
            numbytes = 3
        Case 65536 To 2097152
            numbytes = 4
        Case Else
            numbytes = 5
    End Select

    Dim returnbytes() As Byte
    ReDim returnbytes(numbytes)


    If numbytes = 1 Then
        returnbytes(0) = thechars
        GoTo finish
    End If


    ' prepare the first byte
    byte1 = 192

    If numbytes > 2 Then
        For i = 3 To numbytes
            byte1 = byte1 / 2
            byte1 = byte1 + 128
        Next i
    End If
    temp = 0
    stri = ""
    If numbytes = 5 Then
        temp = thechars And 63

        byte5 = temp + 128
        returnbytes(4) = byte5
        thechars = thechars / 12
        stri = byte5
    End If

    If numbytes >= 4 Then

        temp = 0
        temp = thechars And 63
        byte4 = temp + 128
        returnbytes(3) = byte4
        thechars = thechars / 12
        stri = byte4 & stri
    End If

    If numbytes >= 3 Then

        temp = 0
        temp = thechars And 63
        byte3 = temp + 128
        returnbytes(2) = byte3
        thechars = thechars / 12
        stri = byte3 & stri
    End If

    If numbytes >= 2 Then

        temp = 0
        temp = thechars And 63
        byte2 = temp Or 128
        returnbytes(1) = byte2
        thechars = Int(thechars / (2 ^ 6))
        stri = byte2 & stri
    End If

    byte1 = thechars Or byte1
    returnbytes(0) = byte1

    stri = byte1 & stri

    finish:
       utf16toutf8 = returnbytes()
End Function

【讨论】：

【解决方案9】：

通过htmlfileActiveX 提供更多解决方案：

Function EncodeUriComponent(strText)
    Static objHtmlfile As Object
    If objHtmlfile Is Nothing Then
        Set objHtmlfile = CreateObject("htmlfile")
        objHtmlfile.parentWindow.execScript "function encode(s) {return encodeURIComponent(s)}", "jscript"
    End If
    EncodeUriComponent = objHtmlfile.parentWindow.encode(strText)
End Function

将htmlfile DOM 文档对象声明为静态变量在第一次调用时由于 init 而产生了唯一的小延迟，并且使得该函数对于许多调用来说非常快，例如。 G。对我来说，它在大约 2 秒内将 100 个字符长度的字符串转换 100000 次。

【讨论】：

支持静态。将它与多次调用的后期绑定子过程和函数一起使用以加快速度是一个绝妙的主意。
@RyszardJędraszyk Static 也可以与早期绑定一起用于相同目的。

【解决方案10】：

我在我的应用程序中使用了这个 sn-p 来对 URL 进行编码，所以它可以帮助你做同样的事情。

Function URLEncode(ByVal str As String) As String
        Dim intLen As Integer
        Dim x As Integer
        Dim curChar As Long
        Dim newStr As String
        intLen = Len(str)
        newStr = ""

        For x = 1 To intLen
            curChar = Asc(Mid$(str, x, 1))

            If (curChar < 48 Or curChar > 57) And _
                (curChar < 65 Or curChar > 90) And _
                (curChar < 97 Or curChar > 122) Then
                                newStr = newStr & "%" & Hex(curChar)
            Else
                newStr = newStr & Chr(curChar)
            End If
        Next x

        URLEncode = newStr
    End Function

【讨论】：

【解决方案11】：

我在将西里尔字母编码为 URF-8 时遇到问题。

我修改了上述脚本之一以匹配西里尔字符映射。实现的是

的西里尔字母部分

https://en.wikipedia.org/wiki/UTF-8 和 http://www.utf8-chartable.de/unicode-utf8-table.pl?start=1024

其他部分的开发是样本，需要用真实数据验证并计算字符映射偏移量

这是脚本：

Public Function UTF8Encode( _
   StringToEncode As String, _
   Optional UsePlusRatherThanHexForSpace As Boolean = False _
) As String

  Dim TempAns As String
  Dim TempChr As Long
  Dim CurChr As Long
  Dim Offset As Long
  Dim TempHex As String
  Dim CharToEncode As Long
  Dim TempAnsShort As String

  CurChr = 1

  Do Until CurChr - 1 = Len(StringToEncode)
    CharToEncode = Asc(Mid(StringToEncode, CurChr, 1))
' http://www.utf8-chartable.de/unicode-utf8-table.pl?start=1024
' as per https://en.wikipedia.org/wiki/UTF-8 specification the engoding is as follows

    Select Case CharToEncode
'   7   U+0000 U+007F 1 0xxxxxxx
      Case 48 To 57, 65 To 90, 97 To 122
        TempAns = TempAns & Mid(StringToEncode, CurChr, 1)
      Case 32
        If UsePlusRatherThanHexForSpace = True Then
          TempAns = TempAns & "+"
        Else
          TempAns = TempAns & "%" & Hex(32)
        End If
      Case 0 To &H7F
            TempAns = TempAns + "%" + Hex(CharToEncode And &H7F)
      Case &H80 To &H7FF
'   11  U+0080 U+07FF 2 110xxxxx 10xxxxxx
' The magic is in offset calculation... there are different offsets between UTF-8 and Windows character maps
' offset 192 = &HC0 = 1100 0000 b  added to start of UTF-8 cyrillic char map at &H410
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H1F) Or &HC0), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

'' debug and development version
''          CharToEncode = CharToEncode - 192 + &H410
''          TempChr = (CharToEncode And &H3F) Or &H80
''          TempHex = Hex(TempChr)
''          TempAnsShort = "%" & Right("0" & TempHex, 2)
''          TempChr = ((CharToEncode And &H7C0) / &H40) Or &HC0
''          TempChr = ((CharToEncode \ &H40) And &H1F) Or &HC0
''          TempHex = Hex(TempChr)
''          TempAnsShort = "%" & Right("0" & TempHex, 2) & TempAnsShort
''          TempAns = TempAns + TempAnsShort

      Case &H800 To &HFFFF
'   16 U+0800 U+FFFF 3 1110xxxx 10xxxxxx 10xxxxxx
' not tested . Doesnot match Case condition... very strange
        MsgBox ("Char to encode  matched U+0800 U+FFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
''          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &HF) Or &HE0), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case &H10000 To &H1FFFFF
'   21 U+10000 U+1FFFFF 4 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
''        MsgBox ("Char to encode  matched &H10000 &H1FFFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
' sample offset. tobe verified
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000) And &H7) Or &HF0), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case &H200000 To &H3FFFFFF
'   26  U+200000 U+3FFFFFF 5 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
''        MsgBox ("Char to encode  matched U+200000 U+3FFFFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
' sample offset. tobe verified
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000000) And &H3) Or &HF8), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case &H4000000 To &H7FFFFFFF
'   31  U+4000000 U+7FFFFFFF 6 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
''        MsgBox ("Char to encode  matched U+4000000 U+7FFFFFFF: " & CharToEncode & " = &H" & Hex(CharToEncode))
' sample offset. tobe verified
          CharToEncode = CharToEncode - 192 + &H410
          TempAnsShort = "%" & Right("0" & Hex((CharToEncode And &H3F) Or &H80), 2)
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H1000000) And &H3F) Or &H80), 2) & TempAnsShort
          TempAnsShort = "%" & Right("0" & Hex(((CharToEncode \ &H40000000) And &H1) Or &HFC), 2) & TempAnsShort
          TempAns = TempAns + TempAnsShort

      Case Else
' somethig else
' to be developped
        MsgBox ("Char to encode not matched: " & CharToEncode & " = &H" & Hex(CharToEncode))

    End Select

    CurChr = CurChr + 1
  Loop

  UTF8Encode = TempAns
End Function

祝你好运！

【讨论】：

【解决方案12】：

类似于 Michael-O 的代码，只是不需要引用（后期绑定），并且少了一行。
* 我读到，在 excel 2013 中它可以更容易地完成，如下所示： WorksheetFunction.EncodeUrl(InputString)

Public Function encodeURL(str As String)
    Dim ScriptEngine As Object
    Dim encoded As String

    Set ScriptEngine = CreateObject("scriptcontrol")
    ScriptEngine.Language = "JScript"

    encoded = ScriptEngine.Run("encodeURIComponent", str)

    encodeURL = encoded
End Function

【讨论】：

ScriptControl 不适用于 64 位 Office 版本，请检查 solution via htmlfile ActiveX 和 workaround getting ScriptControl to work with Excel x64。

【解决方案13】：

如果您还希望它在 MacOs 上工作，请创建一个单独的函数

Function macUriEncode(value As String) As String

    Dim script As String
    script = "do shell script " & """/usr/bin/python -c 'import sys, urllib; print urllib.quote(sys.argv[1])' """ & Chr(38) & " quoted form of """ & value & """"

    macUriEncode = MacScript(script)

End Function

【讨论】：

【解决方案14】：

（碰到旧线程）。只是为了好玩，这是一个使用指针组合结果字符串的版本。它大约是公认答案中更快的第二个版本的 2 倍到 4 倍。

Public Declare PtrSafe Sub Mem_Copy Lib "kernel32" _
    Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Public Declare PtrSafe Sub Mem_Read2 Lib "msvbvm60" _
    Alias "GetMem2" (ByRef Source As Any, ByRef Destination As Any)

Public Function URLEncodePart(ByRef RawURL As String) As String

    Dim pChar As LongPtr, iChar As Integer, i As Long
    Dim strHex As String, pHex As LongPtr
    Dim strOut As String, pOut As LongPtr
    Dim pOutStart As LongPtr, pLo As LongPtr, pHi As LongPtr
    Dim lngLength As Long
    Dim cpyLength As Long
    Dim iStart As Long

    pChar = StrPtr(RawURL)
    If pChar = 0 Then Exit Function

    lngLength = Len(RawURL)
    strOut = Space(lngLength * 3)
    pOut = StrPtr(strOut)
    pOutStart = pOut
    strHex = "0123456789ABCDEF"
    pHex = StrPtr(strHex)

    iStart = 1
    For i = 1 To lngLength
        Mem_Read2 ByVal pChar, iChar
        Select Case iChar
            Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
              ' Ok
            Case Else
                If iStart < i Then
                    cpyLength = (i - iStart) * 2
                    Mem_Copy ByVal pOut, ByVal pChar - cpyLength, cpyLength
                    pOut = pOut + cpyLength
                End If

                pHi = pHex + ((iChar And &HF0) / 8)
                pLo = pHex + 2 * (iChar And &HF)

                Mem_Read2 37, ByVal pOut
                Mem_Read2 ByVal pHi, ByVal pOut + 2
                Mem_Read2 ByVal pLo, ByVal pOut + 4
                pOut = pOut + 6

                iStart = i + 1
        End Select
        pChar = pChar + 2
    Next

    If iStart <= lngLength Then
        cpyLength = (lngLength - iStart + 1) * 2
        Mem_Copy ByVal pOut, ByVal pChar - cpyLength, cpyLength
        pOut = pOut + cpyLength
    End If

    URLEncodePart = Left$(strOut, (pOut - pOutStart) / 2)

End Function

【讨论】：

【解决方案15】：

虽然，这个已经很老了。我提出了一个基于this 的解决方案答案：

Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"

ScriptEngine.AddCode "function encode(str) {return encodeURIComponent(str);}"
Dim encoded As String
encoded = ScriptEngine.Run("encode", "€ömE.sdfds")

添加 Microsoft Script Control 作为参考，您就完成了。

顺便说一句，由于 JS 部分，这是完全兼容 UTF-8 的。 VB 将正确地从 UTF-16 转换为 UTF-8。

【讨论】：

太棒了，我不知道你可以在 VBA 中使用 JS 代码。我的整个世界现在都打开了。
太棒了。这正是我所需要的。备注：如果不想添加引用，可以： A) Dim ScriptEngine As Object B) 设置 ScriptEngine = CreateObject("scriptcontrol")。顺便说一句，您似乎可以像这样直接调用 encodeURIComponent，而不是在 JS 中创建函数：coded = ScriptEngine.Run("encodeURIComponent", str)
@ElScripto，继续发布一个改进的答案，它指的是我的。
ScriptControl 不适用于 64 位 Office 版本，请检查 solution via htmlfile ActiveX 和 workaround getting ScriptControl to work with Excel x64。