如何在Excel VBA中对URL进行URL编码？
有没有一种内置的方式来对Excel VBA中的string进行URL编码，还是需要手动滚动此function？
不，没有内置（ 直到Excel 2013 – 看到这个答案 ）。
在这个答案中有三个版本的URLEncode() 。
- 一个支持UTF-8的函数。 你可能应该使用这个 （或Tom 的替代实现 ）来兼容现代的需求。
- 为了参考和教育目的，两个没有UTF-8支持的function：
- 一个在第三方网站上发现，包括在内。 （这是答案的第一个版本）
- 一个优化版本，由我写的
支持UTF-8编码并基于ADODB.Stream的变体（包括对项目中“Microsoft ActiveX数据对象”库的最新版本的引用）：
Public Function URLEncode( _ 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
这个函数是在freevbcode.com上find的 ：
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编码。
以上支持UTF8的版本：
Private Const CP_UTF8 = 65001 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 cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long Public Function UTF16To8(ByVal UTF16 As String) As String Dim sBuffer As String Dim lLength As Long If UTF16 <> "" Then lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0) sBuffer = Space$(lLength) lLength = WideCharToMultiByte( CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0) 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
请享用！
为了使这个更新，从Excel 2013开始，现在有了一个内置的使用工作表函数ENCODEURL编码URL的方法。
要在你的VBA代码中使用它，你只需要打电话
EncodedUrl = WorksheetFunction.EncodeUrl(InputString)
文档
虽然这个很老了 我在这个答案中提出了一个解决scheme：
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脚本控制作为参考，你已经完成。
只是一个侧面说明，因为JS部分，这完全是UTF-8兼容。 VB将正确地从UTF-16转换为UTF-8。
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脚本控制作为参考，你已经完成。
和上一篇文章一样，完整的function..works！
类似于Michael-O的代码，只需要引用（后期绑定）和less一行。
*我读到，在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
（在旧线程上碰撞）。 只是踢，这是一个使用指针来组装结果string的版本。 这是接受答案中速度的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
通过htmlfile ActiveX还有一个解决scheme：
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文档对象声明为静态variables，由于init的原因，第一次被调用的时候会给出一个小的延迟，并且使得这个函数对于多次调用来说非常快，例如对于我来说，它在2秒内将长度为100000的string转换为100000次。
如果你还希望它在MacOs上工作，创build一个单独的function
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
我对编码西里尔字母到URF-8有问题。
我修改了上面的脚本之一来匹配西里尔字符映射。 被践踏的是cyrrilic部分
https://en.wikipedia.org/wiki/UTF-8和http://www.utf8-chartable.de/unicode-utf8-table.pl?start=1024
其他部分的开发是样本，需要用真实数据进行validation，并计算字符映射偏移量
这是脚本：
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
祝你好运！
这个片段我用我的应用程序来编码的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
这里没有任何解决scheme为我提供了开箱即用的function，但这很可能是因为我缺乏VBA的经验。 也可能是因为我简单地复制并粘贴了上面的一些function，而不知道可能需要使它们在VBA上工作以用于应用程序环境的细节。
我的需求是简单地使用包含挪威语言的一些特殊字符的url发送xmlhttp请求。 上面的一些解决scheme甚至编码冒号，这使得urls不适合我所需要的。
然后我决定写我自己的URLEncode函数。 它不会使用更多聪明的编程，如@ndd和@Tom。 我不是一个非常有经验的程序员，但是我必须尽快完成。
我意识到问题是我的服务器不接受UTF-16编码，所以我不得不编写一个将UTF-16转换为UTF-8的函数。 在这里和这里find了一个很好的信息来源。
我还没有广泛地testing它，以检查它是否与具有更高的Unicode值的字符，并将产生超过2字节的utf-8字符的url。 我并不是说它会解码所有需要解码的东西（但是很容易修改为在select case语句中包含/排除字符），也不能用于更高的字符，因为我还没有完全testing。 但我正在分享代码，因为它可能会帮助试图理解问题的人。
任何意见，欢迎。
Function URLEncode(st As String) As String Dim eachbyte() As Byte Dim encodedurl As String encodedurl = "" 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 URLEncode = 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 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
