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

Question

提问by Matthew Murdoch

Is there a built-in way to URL encode a string in Excel VBA or do I need to hand roll this functionality?

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

Answer 1

回答by Tomalak

No, nothing built-in (until Excel 2013 - see this answer).

不，没有内置（直到 Excel 2013 -请参阅此答案）。

There are three versions of URLEncode()in this answer.

URLEncode()这个答案有三个版本。

A function with UTF-8 support. You should probably use this one(or the alternative implementationby Tom) for compatibility with modern requirements.
For reference and educational purposes, two functions without UTF-8 support:
- one found on a third party website, included as-is. (This was the first version of the answer)
- one optimized version of that, written by me

支持 UTF-8 的函数。为了与现代需求兼容，您可能应该使用这个（或Tom的替代实现）。
出于参考和教育目的，两个不支持 UTF-8 的函数：
- 在第三方网站上找到的一个，按原样包含。（这是答案的第一个版本）
- 我写的一个优化版本

A variant that supports UTF-8 encoding and is based on ADODB.Stream(include a reference to a recent version of the "Microsoft ActiveX Data Objects" library in your project):

支持 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

This function was found on freevbcode.com:

这个函数是在 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

I've corrected a little bug that was in there.

我已经纠正了那里的一个小错误。

I would use more efficient (~2× as fast) version of the above:

我会使用更高效（约 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

Note that neither of these two functions support UTF-8 encoding.

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

Answer 2

回答by Jamie Bull

For the sake of bringing this up to date, since Excel 2013 there is now a built-in way of encoding URLs using the worksheet function ENCODEURL.

为了使之与时俱进，自 Excel 2013 起，现在有一种使用工作表函数对 URL 进行编码的内置方法ENCODEURL。

To use it in your VBA code you just need to call

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

EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

Documentation

文档

Answer 3

回答by Tom

Version of the above supporting UTF8:

以上支持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

Enjoy!

享受！

Answer 4

回答by Michael-O

Although, this one is very old. I have come up with a solution based in thisanswer:

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

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")

Add Microsoft Script Control as reference and you are done.

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

Just a side note, because of the JS part, this is fully UTF-8-compatible. VB will convert correctly from UTF-16 to UTF-8.

只是附带说明，由于 JS 部分，这是完全兼容 UTF-8 的。VB 将正确地从 UTF-16 转换为 UTF-8。

Answer 5

回答by El Scripto

Similar to Michael-O's code, only without need to reference (late bind) and with less one line .
* I read, that in excel 2013 it can be done more easily like so: WorksheetFunction.EncodeUrl(InputString)

与 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

Answer 6

回答by ozmike

Since office 2013 use this inbuilt function here.

自 office 2013 起，请在此处使用此内置功能。

If before office 2013

如果在办公室 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

Add Microsoft Script Control as reference and you are done.

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

Same as last post just complete function ..works!

与上一篇文章相同，只是完整的功能..有效！

Answer 7

回答by omegastripes

One more solution via htmlfileActiveX:

通过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

Declaring htmlfileDOM document object as static variable gives the only small delay when called first time due to init, and makes this function very fast for numerous calls, e. g. for me it converts the string of 100 chars length 100000 times in 2 seconds approx..

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

Answer 8

回答by Joshua Honig

(Bump on an old thread). Just for kicks, here's a version that uses pointers to assemble the result string. It's about 2x - 4x as fast as the faster second version in the accepted answer.

（撞到旧线程）。只是为了踢球，这里有一个使用指针来组装结果字符串的版本。它大约是已接受答案中更快的第二个版本的 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

Answer 9

回答by Florent B.

Same as WorksheetFunction.EncodeUrlwith UTF-8 support:

同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

Answer 10

回答by ADJenks

The VBA-tools library has a function for that:

VBA-tools 库有一个功能：

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

It seems to work similar to encodeURIComponent()in JavaScript.

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

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

提问by Matthew Murdoch

回答by Tomalak

回答by Jamie Bull

回答by Tom

回答by Michael-O

回答by El Scripto

回答by ozmike

回答by omegastripes

回答by Joshua Honig

回答by Florent B.

回答by ADJenks

相关推荐

最近更新

标签

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

提问by Matthew Murdoch

回答by Tomalak

回答by Jamie Bull

回答by Tom

回答by Michael-O

回答by El Scripto

回答by ozmike

回答by omegastripes

回答by Joshua Honig

回答by Florent B.

回答by ADJenks

相关推荐

VBA Excel“编译错误：需要对象”

vba VBA数组排序函数？

让 Excel 从 VBA 中刷新工作表上的数据

vba 使用excel vba过滤出多个条件

相关推荐

最近更新

标签