How can I URL encode a string in Excel VBA?
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 IfEnd 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 = TempAnsEnd 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 IfEnd 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 IfPublic Function UTF16To8(ByVal UTF16 As String) As StringDim sBuffer As StringDim lLength As LongIf 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 IfEnd FunctionPublic Function URLEncode( _ StringVal As String, _ Optional SpaceAsPlus As Boolean = False, _ Optional UTF8Encode As Boolean = True _) As StringDim 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 IfEnd Function
Enjoy!