VB6 - URLencode & URLdecode

URLencode and URLdecode are functions that take a string and convert it to/from string that can be used as a GET item or it's value in a URL.

Rules:

• A-Z, a-z and 0-9 are retained as-is
• Space is converted to + (but %20 is also valid)
• Any other character is converted to two character hex number prepended with a %
• Optional: Unicode characters support (all versions below are ANSI only)

Make shorter than these:

Code:

---

Public Function URLdecshort(ByRef Text As String) As String
    Dim strArray() As String, lngA As Long
    strArray = Split(Replace(Text, "+", " "), "%")
    For lngA = 1 To UBound(strArray)
        strArray(lngA) = Chr$("&H" & Left$(strArray(lngA), 2)) & Mid$(strArray(lngA), 3)
    Next lngA
    URLdecshort = Join(strArray, vbNullString)
End Function

Public Function URLencshort(ByRef Text As String) As String
    Dim lngA As Long, strChar As String
    For lngA = 1 To Len(Text)
        strChar = Mid$(Text, lngA, 1)
        If strChar Like "[A-Za-z0-9]" Then
        ElseIf strChar = " " Then
            strChar = "+"
        Else
            strChar = "%" & Right$("0" & Hex$(Asc(strChar)), 2)
        End If
        URLencshort = URLencshort & strChar
    Next lngA
End Function

---

Make faster than these:

Code:

---

Public Function URLdecode(ByRef Text As String) As String
    Const Hex = "0123456789ABCDEF"
    Dim lngA As Long, lngB As Long, lngChar As Long, lngChar2 As Long
    URLdecode = Text
    lngB = 1
    For lngA = 1 To LenB(Text) - 1 Step 2
        lngChar = Asc(MidB$(URLdecode, lngA, 2))
        Select Case lngChar
            Case 37
                lngChar = InStr(Hex, MidB$(Text, lngA + 2, 2)) - 1
                If lngChar >= 0 Then
                    lngChar2 = InStr(Hex, MidB$(Text, lngA + 4, 2)) - 1
                    If lngChar2 >= 0 Then
                        MidB$(URLdecode, lngB, 2) = Chr$((lngChar * &H10&) Or lngChar2)
                        lngA = lngA + 4
                    Else
                        If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(Text, lngA, 2)
                    End If
                Else
                    If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(Text, lngA, 2)
                End If
            Case 43
                MidB$(URLdecode, lngB, 2) = " "
            Case Else
                If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(Text, lngA, 2)
        End Select
        lngB = lngB + 2
    Next lngA
    URLdecode = LeftB$(URLdecode, lngB - 1)
End Function

Public Function URLencode(ByRef Text As String) As String
    Const Hex = "0123456789ABCDEF"
    Dim lngA As Long, lngChar As Long
    URLencode = Text
    For lngA = LenB(URLencode) - 1 To 1 Step -2
        lngChar = Asc(MidB$(URLencode, lngA, 2))
        Select Case lngChar
            Case 48 To 57, 65 To 90, 97 To 122
            Case 32
                MidB$(URLencode, lngA, 2) = "+"
            Case Else
                URLencode = LeftB$(URLencode, lngA - 1) & "%" & Mid$(Hex, (lngChar And &HF0) \ &H10 + 1, 1) & Mid$(Hex, (lngChar And &HF&) + 1, 1) & MidB$(URLencode, lngA + 2)
        End Select
    Next lngA
End Function

---

Code for timing:

Code:

---

Option Explicit

Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean

Dim m_Time As Double
Dim m_TimeFreq As Double
Dim m_TimeStart As Currency

Public Property Get Timing() As Double
    Dim curTime As Currency
    QueryPerformanceCounter curTime
    Timing = (curTime - m_TimeStart) * m_TimeFreq + m_Time
End Property

Public Property Let Timing(ByVal NewValue As Double)
    Dim curFreq As Currency, curOverhead As Currency
    m_Time = NewValue
    QueryPerformanceFrequency curFreq
    m_TimeFreq = 1 / curFreq
    QueryPerformanceCounter curOverhead
    QueryPerformanceCounter m_TimeStart
    m_TimeStart = m_TimeStart + (m_TimeStart - curOverhead)
End Property

---

Timing usage:

Code:

---

' before benchmark
Timing = 0

' after benchmark
Debug.Print "Result: " & Format$(Timing, "0.000000")

---

As far as I know, you can make a shorter code than the first two examples above and you can also make (much) faster than the next two examples above :)

You can also do this via API calls, with some interesting differences. See the comments in URLUtility.cls for one oddity.

I haven't timed this, but without the hack for "space to +" encoding it should be reasonably quick.

Great!

Caution:

It doesn't appear that any of the code above handles URLs that are encoded as UTF-8 before URL Encoding. UTF-8 is now common and standard, so be cautious.

The API calls I used don't help either, the flag needed to support UTF-8 doesn't exist until Windows 8.

I wrote a URLencode function that supports UTF8 heavily modified and tweaked from an example i found on the web. I managed to more than double the speed of the original code. As you can see it is only about 10 nanoseconds slower than the non-UTF8 functions. Dillantes API code is the fastest at the cost of no UTF8 support. I also tweaked Merri's example but only made minimal gains since URLs are generally only 50-100 characters and string caching gains arent noticeable on small data. I will edit once i get a decode function written with UTF8 support.

UTF8 encode

Code:

---

Public Function URLEncode_UTF8(ByVal sText As String) As String

    Dim x1 As Long
    Dim x2 As Long
    Dim Chars() As Byte
    Dim Byte1 As Byte
    Dim Byte2 As Byte
    Dim UTF16 As Long
   
    For x1 = 1 To Len(sText)
        CopyMemory Byte1, ByVal StrPtr(sText) + ((x1 - 1) * 2), 1
        CopyMemory Byte2, ByVal StrPtr(sText) + ((x1 - 1) * 2) + 1, 1

        UTF16 = Byte2 * 256 + Byte1

        If UTF16 < &H80 Then
            ReDim Chars(0) As Byte
            Chars(0) = UTF16
        ElseIf UTF16 < &H800 Then
            ReDim Chars(1) As Byte
            Chars(1) = &H80 + (UTF16 And &H3F)
            UTF16 = UTF16 \ &H40
            Chars(0) = &HC0 + (UTF16 And &H1F)
        Else
            ReDim Chars(2) As Byte
            Chars(2) = &H80 + (UTF16 And &H3F)
            UTF16 = UTF16 \ &H40
            Chars(1) = &H80 + (UTF16 And &H3F)
            UTF16 = UTF16 \ &H40
            Chars(0) = &HE0 + (UTF16 And &HF)
        End If

        For x2 = 0 To UBound(Chars)
            Select Case Chars(x2)
                Case 48 To 57, 65 To 90, 97 To 122
                    URLEncode_UTF8 = URLEncode_UTF8 & Chr$(Chars(x2))
                Case Else
                    URLEncode_UTF8 = URLEncode_UTF8 & ("%" & Hex$(Chars(x2)))
            End Select
        Next
    Next

End Function

---

Tweaked Merri code

Code:

---

Public Function URLEncode(ByVal sText As String) As String

    Const Hex As String = "0123456789ABCDEF"

    Dim X As Long, lngChar As Long, lLen As Long, lIndex As Long

    lLen = Len(sText)
    URLEncode = Space$(lLen * 3)

    lIndex = 1
    For X = 1 To lLen
        lngChar = Asc(Mid$(sText, X, 1))
        Select Case lngChar
            Case 48 To 57, 65 To 90, 97 To 122
                Mid(URLEncode, lIndex, 1) = Chr$(lngChar)
                lIndex = lIndex + 1
            Case 32
                Mid$(URLEncode, lIndex, 1) = "+"
                lIndex = lIndex + 1
            Case Else
                Mid(URLEncode, lIndex, 3) = "%" & Mid$(Hex, (lngChar And &HF0) \ &H10 + 1, 1) & Mid$(Hex, (lngChar And &HF&) + 1, 1)
                lIndex = lIndex + 3
        End Select
    Next X

    URLEncode = Left$(URLEncode, lIndex - 1)

End Function

---

Attachment 179548

Was looking for this too, but the Merri's decode is CASE SENSITIVE, whereas url URL percent-encoding is NOT case sensitive according to RFC 3986:

So make sure you add vbTextCompare to the InStr of Merri's code, as default it's vbBinaryCompare

Code:

---

lngChar = InStr(1, Hex, MidB$(Text, lngA + 2, 2), vbTextCompare) - 1

lngChar2 = InStr(1, Hex, MidB$(Text, lngA + 4, 2), vbTextCompare) - 1

---

I haven't timed it, but an alternative way to decoding the hex part might be the following:
(this is slower if Instr is faster then Asc in combination with the extra Select Case's)

Code:

---

        '--------------------------------------------------------------
        'Get next character to check if it's a hexadecimal character
        lngChar = Asc(MidB$(Text, lngA + 2, 2))
        Select Case lngChar
          '--------------------------------------------------------------
          '0-9/A-F/a-f
          Case 48 To 57, _
              65 To 70, _
              97 To 102
            '--------------------------------------------------------------
            'Convert character back to number
            Select Case lngChar
              Case Is < 65: lngChar = lngChar - 48
              Case Is < 97: lngChar = lngChar - 55 'A=10 (-65 would make it 0)
              Case Else:    lngChar = lngChar - 87 'a=10 (-97 would make it 0)
            End Select
            '--------------------------------------------------------------
            'Get next character to check if it's a hexadecimal character
            lngChar2 = Asc(MidB$(Text, lngA + 4, 2))
            Select Case lngChar2
              '--------------------------------------------------------------
              '0-9/A-F/a-f
              Case 48 To 57, _
                  65 To 70, _
                  97 To 102
                '--------------------------------------------------------------
                'Convert character back to number
                Select Case lngChar2
                  Case Is < 65: lngChar2 = lngChar2 - 48
                  Case Is < 97: lngChar2 = lngChar2 - 55 'A=10 (-65 would make it 0)
                  Case Else:    lngChar2 = lngChar2 - 87 'a=10 (-97 would make it 0)
                End Select
                '--------------------------------------------------------------
                'add converted character
                MidB$(URLdecode, lngB, 2) = Chr$((lngChar * &H10&) Or lngChar2)
                lngA = lngA + 4
              '--------------------------------------------------------------
              '%
              Case Else
                '--------------------------------------------------------------
                'Add original character
                If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(Text, lngA, 2)
            End Select
          '--------------------------------------------------------------
          '%
          Case Else
            If lngB < lngA Then MidB$(URLdecode, lngB, 2) = MidB$(Text, lngA, 2)
        End Select

---