How can I URL encode a string in Excel VBA?

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

130764 次浏览
小开
最佳答案

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

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

  • A function with UTF-8 support. You should probably use this one (or the alternative implementation by 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

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

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:

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:

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.

小开

Version of the above supporting 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!

小开

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

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.

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.

小开

Since office 2013 use this inbuilt function here.

If before office 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.

Same as last post just complete function ..works!

小开

(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.

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
小开

If you also want it to work on MacOs create a seperate 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
小开

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.

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

EncodedUrl = WorksheetFunction.EncodeUrl(InputString)

Documentation

小开

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)

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
小开

I had problem with encoding cyrillic letters to URF-8.

I modified one of the above scripts to match cyrillic char map. Implmented is the cyrrilic section of

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

Other sections development is sample and need verification with real data and calculate the char map offsets

Here is the script: 

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

Good luck!

小开

This snippet i have used in my application to encode the URL so may this can help you to do the same. 

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
小开

One more solution via htmlfile ActiveX:

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 htmlfile DOM 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..

小开

None of the solutions here worked for me out of the box, but it was most likely due my lack of experience with VBA. It might also be because I simply copied and pasted some of the functions above, not knowing details that maybe are necessary to make them work on a VBA for applications environment.

My needs were simply to send xmlhttp requests using urls that contained some special characters of the Norwegian language. Some of the solutions above encode even colons, which made the urls unsuitable for what I needed.

I then decided to write my own URLEncode function. It does not use more clever programming such as the one from @ndd and @Tom. I am not a very experienced programmer, but I had to make this done sooner.

I realized that the problem was that my server didn't accept UTF-16 encodings, so I had to write a function that would convert UTF-16 to UTF-8. A good source of information was found here and here.

I haven't tested it extensively to check if it works with url with characters that have higher unicode values and which would produce more than 2 bytes of utf-8 characters. I am not saying it will decode everything that needs to be decoded (but it is easy to modify to include/exclude characters on the select case statement) nor that it will work with higher characters, as I haven't fully tested. But I am sharing the code because it might help someone who is trying to understand the issue.

Any comments are welcome.

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
小开

Same as WorksheetFunction.EncodeUrl with UTF-8 support:

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
小开

The VBA-tools library has a function for that:

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

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

小开

The accepted answer's code stopped on a Unicode error in Access 2013, so I wrote a function for myself with high readability that should follow RFC 3986 according to Davis Peixoto, and cause minimal trouble in various environments.

Note: The percent sign itself must be replaced first, or it will double-encode any previously encoded characters. Replacing space with + was added, not to conform with RFC 3986, but to provide links that don't break due to formatting. It is optional.

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
小开

The best of both worlds. This function uses the new(ish) worksheet function ENCODEURL() if the workbook is open in Excel 2013 or newer.

If it's an older version of Excel then this function uses htmlfile instead.

You can also force this function to use htmlfile by passing True as the optional bForceOldSchool argument.

Function URLEncode$(s$, Optional bForceOldSchool As Boolean)
Select Case True
Case bForceOldSchool Or Val(Application.Version) < 15
URLEncode = CreateObject("htmlfile").parentWindow.EncodeUriComponent(s)
Case Else: URLEncode = WorksheetFunction.EncodeURL(s)
End Select
End Function

提交答案