Foro de elhacker.net

Function URLEncode(url As String) As String
Dim sp() As Byte
Dim final As String
 
sp() = StrConv(url, vbFromUnicode)
 
For i = 0 To UBound(sp)
 
Select Case sp(i)
 
    Case 45, 46, 48 To 57, 65 To 90, 95, 97 To 122, 126
         final = final & Chr(sp(i))
 
    Case 32
        final = final & "+"
 
   Case Else
           final = final & "%" & Hex(sp(i))
End Select
 
Next
URLEncode= final
End Function

Function URLDecode(url As String) As String
Dim spl() As String
Dim final As String
Dim str As String
str = Replace(url, "+", " ")
spl() = Split(str, "%")
final = spl(0)
For i = 1 To UBound(spl)
final = final & Chr(CLng("&H" & Left(spl(i), 2))) & Mid(spl(i), 3)
Next
URLDecode = final
End Function

Option Explicit
Private Declare Sub InternetCanonicalizeUrl Lib "wininet.dll" Alias "InternetCanonicalizeUrlA" (ByVal lpszUrl As String, ByVal lpszBuffer As String, ByRef lpdwBufferLength As Long, ByVal dwFlags As Long)
Private Const INTERNET_MAX_URL_LENGTH As Long = 2048
Private Const ICU_BROWSER_MODE As Long = &H2000000
Private Const ICU_DECODE As Long = &H10000000
Private Const ICU_ENCODE_PERCENT As Long = &H1000
Private Const ICU_ENCODE_SPACES_ONLY As Long = &H4000000
Private Const ICU_NO_ENCODE As Long = &H20000000
Private Const ICU_ESCAPE As Long = &H80000000
Private Const ICU_NO_META As Long = &H8000000
 
 
Private Sub Form_Load()
    Debug.Print UrlEncode("https://www.google.com.ar/search?q=canción animal")
    'https://www.google.com.ar/search?q=casa%20duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr%3A1%2Ccd_min%3A5%2F12%2F2012%2Ccd_max%3A18%2F12%2F2012&tbm=isch
    Debug.Print UrlEncode("https://www.google.com.ar/search?q=casa duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr:1,cd_min:5/12/2012,cd_max:18/12/2012&tbm=isch")
End Sub
 
Private Function UrlEncode(sURL As String, Optional ByVal SpacePlus As Boolean) As String
 
    Dim sBuffer As String, lBufferLength As Long
 
    sBuffer = String$(INTERNET_MAX_URL_LENGTH, 0)
    lBufferLength = INTERNET_MAX_URL_LENGTH
    InternetCanonicalizeUrl sURL, sBuffer, lBufferLength, ICU_ENCODE_PERCENT Or (ICU_ENCODE_SPACES_ONLY * SpacePlus)
    If lBufferLength > 0 Then UrlEncode = Left$(sBuffer, lBufferLength)
 
End Function
 

Option Explicit
Option Base 0
 
Enum eMaxWinInetValues
  INTERNET_MAX_HOST_NAME_LENGTH = 256
  INTERNET_MAX_USER_NAME_LENGTH = 128
  INTERNET_MAX_PASSWORD_LENGTH = 128
  INTERNET_MAX_PORT_NUMBER_LENGTH = 5          ' INTERNET_PORT is unsigned short
  INTERNET_MAX_PORT_NUMBER_VALUE = 65535       ' maximum unsigned short value
  INTERNET_MAX_PATH_LENGTH = 2048
  INTERNET_MAX_SCHEME_LENGTH = 32              ' longest protocol name length
  INTERNET_MAX_URL_LENGTH = INTERNET_MAX_SCHEME_LENGTH + 3 + INTERNET_MAX_PATH_LENGTH
End Enum
 
Public Type URL_COMPONENTSA
  dwStructSize As Long
  lpszScheme As String
  dwSchemeLength As Long
  nScheme As INTERNET_SCHEME
  lpszHostName As String
  dwHostNameLength As Long
  nPort As Integer
 
  lpszUsername As String
  dwUserNameLength As Long
  lpszPassword As String
  dwPasswordLength As Long
 
  lpszUrlPath As String
  dwUrlPathLength As Long
  lpszExtraInfo As String
  dwExtraInfoLength As Long
End Type
 
Enum eCanonizeURL
  ICU_ESCAPE = &H80000000       ' (un)escape URL characters
  ICU_DECODE = &H10000000       ' Convert %XX escape sequences To characters
End Enum
 
Enum INTERNET_SCHEME
    INTERNET_SCHEME_PARTIAL = -2
    INTERNET_SCHEME_UNKNOWN = -1
    INTERNET_SCHEME_DEFAULT = 0
    INTERNET_SCHEME_FTP
    INTERNET_SCHEME_GOPHER
    INTERNET_SCHEME_HTTP
    INTERNET_SCHEME_HTTPS
    INTERNET_SCHEME_FILE
    INTERNET_SCHEME_NEWS
    INTERNET_SCHEME_MAILTO
    INTERNET_SCHEME_SOCKS
    INTERNET_SCHEME_FIRST = INTERNET_SCHEME_FTP
    INTERNET_SCHEME_LAST = INTERNET_SCHEME_SOCKS
End Enum
 
Declare Function InternetCrackUrl Lib "WININET" Alias "InternetCrackUrlA" ( _
    ByVal lpszUrl As String, _
    ByVal dwUrlLength As Long, _
    ByVal dwFlags As eCanonizeURL, _
    lpUrlComponents As URL_COMPONENTSA) As Long
 
Declare Function PathIsURL Lib "shlwapi" Alias "PathIsURLA" ( _
    ByVal pszPath As String) As Long
 
Public Const URIReserved = "!#%&'()*+,/:;=?@[]" 'Caracteres reservados
 
Public Function CrackURL(ByVal URL As String) As URL_COMPONENTSA
  Dim c As URL_COMPONENTSA, Result As Long
 
  c.dwStructSize = 60
  c.lpszScheme = Space(INTERNET_MAX_SCHEME_LENGTH)
  c.dwSchemeLength = INTERNET_MAX_SCHEME_LENGTH
  c.lpszHostName = Space(INTERNET_MAX_HOST_NAME_LENGTH)
  c.dwHostNameLength = INTERNET_MAX_HOST_NAME_LENGTH
 
  c.lpszUsername = Space(INTERNET_MAX_USER_NAME_LENGTH)
  c.dwUserNameLength = INTERNET_MAX_USER_NAME_LENGTH
  c.lpszPassword = Space(INTERNET_MAX_USER_NAME_LENGTH)
  c.dwPasswordLength = INTERNET_MAX_USER_NAME_LENGTH
 
  c.lpszUrlPath = Space(INTERNET_MAX_PATH_LENGTH)
  c.dwUrlPathLength = INTERNET_MAX_PATH_LENGTH
  'fix: extend size of extraInfo to len of url
  c.lpszExtraInfo = Space(Len(URL))
  c.dwExtraInfoLength = Len(URL)
  Result = InternetCrackUrl(URL, 0, 0, c)
  If Result Then
    c.lpszScheme = Left$(c.lpszScheme, c.dwSchemeLength)
    c.lpszHostName = Left$(c.lpszHostName, c.dwHostNameLength)
 
    c.lpszUsername = Left$(c.lpszUsername, c.dwUserNameLength)
    c.lpszPassword = Left$(c.lpszPassword, c.dwPasswordLength)
 
    c.lpszUrlPath = Left$(c.lpszUrlPath, c.dwUrlPathLength)
    c.lpszExtraInfo = Left$(c.lpszExtraInfo, c.dwExtraInfoLength)
  Else
    c.lpszScheme = ""
    c.lpszHostName = ""
 
    c.lpszUsername = ""
    c.lpszPassword = ""
 
    c.lpszUrlPath = ""
    c.lpszExtraInfo = ""
  End If
  CrackURL = c
End Function
 
Function isPrint(Car As String) As Boolean
'Devuelve si un caracter es imprimible (según: http://en.wikipedia.org/wiki/Isprint)
'Similar a isprint de C
If Len(Car) <> 1 Then
    isPrint = False
Else
    isPrint = (Asc(Car) >= 32) And (Asc(Car) <= 126)
End If
End Function
 
Function HexB(Num As Byte) As String
'Devuel el valor Hexa de un byte con padding
Dim strAux As String
 
strAux = Hex(Num)
If Len(strAux) = 1 Then
    strAux = "0" + strAux
End If
HexB = strAux
End Function
 
Public Function EncodeAscii(Cadena As String, SpacePlus As Boolean) As String
Dim I As Long
Dim Car As String
Dim sRet As String
 
sRet = ""
For I = 1 To Len(Cadena)
    Car = Mid(Cadena, I, 1)
    If (InStr(1, URIReserved, Car) > 0) Or (Not isPrint(Car)) Then
        'contempla los espacios
        If SpacePlus And (Asc(Car) = 32) Then
            sRet = sRet + "+"
        Else
            sRet = sRet + "%"
            sRet = sRet + HexB(Asc(Car))
        End If
    Else
        'char comun
        sRet = sRet + Car
    End If
Next I
EncodeAscii = sRet
End Function
 
Public Function isValidExtraInfo(Cadena As String) As Boolean
isValidExtraInfo = (InStr(1, Cadena, "?") <> 0) And (InStr(1, Cadena, "=") <> 0)
End Function
 
Public Function URLEncode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
Dim URLComponents As URL_COMPONENTSA
Dim sParams As String
Dim mExtraValues() As String
Dim mExtraValuePair() As String
Dim sRet As String
Dim I As Long
Dim Car As String
 
'verifica que sea un URL válido
If Not PathIsURL(sURL) Then URLEncode = ""
 
'parsea URL
URLComponents = CrackURL(sURL)
'URI = <scheme>://<host>/<path>;<params>?<query>#<fragment>
'M$ URL = <scheme>://<user>:<pass>@<host>/<path>;<params>?<query>#<fragment>
 
'Re-Armar URL
'scheme
If URLComponents.lpszScheme <> "" Then
    sRet = URLComponents.lpszScheme + "://"
End If
'user,pass,host,port
If URLComponents.lpszUsername <> "" Then
    sRet = sRet + URLComponents.lpszUsername + ":"
End If
If URLComponents.lpszPassword <> "" Then
    sRet = sRet + URLComponents.lpszPassword + "@"
End If
sRet = sRet + URLComponents.lpszHostName
If URLComponents.nPort <> 0 Then
    sRet = sRet + ":" & URLComponents.nPort
End If
'path
sRet = sRet + URLComponents.lpszUrlPath
 
'Ahora lo pedido: convertir los extras
'extras format: "?" + <ID> + "=" + <Value> + "&"
'lo que se encodea es sólo <Value>
If (URLComponents.dwExtraInfoLength > 4) And isValidExtraInfo(URLComponents.lpszExtraInfo) Then
    'para evitar errores, el largo MINIMO deberia ser de 4 caracteres: "?" + <ID> + "=" + <Value>
    sRet = sRet + "?"
    sParams = Mid(URLComponents.lpszExtraInfo, 2, Len(URLComponents.lpszExtraInfo))
    mExtraValues = Split(sParams, "&")
    For I = 0 To UBound(mExtraValues)
        mExtraValuePair = Split(mExtraValues(I), "=")
        sRet = sRet + mExtraValuePair(0) + "=" + EncodeAscii(mExtraValuePair(1), SpacePlus) + "&"
    Next I
    'borrar '&' final
    sRet = Mid(sRet, 1, Len(sRet) - 1)
ElseIf URLComponents.dwExtraInfoLength > 0 Then
    sRet = sRet + URLComponents.lpszExtraInfo
End If
URLEncode = sRet
End Function
 
Public Function URLDecode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
''Lo inverso al Encode :)
End Function
 

Public Function URLEncode(ByVal sUrl As String) As String
    Dim objSC As Object
    Dim sPart() As String
    sPart = Split(sUrl, "?")
    If UBound(sPart) > 0 Then
        Set objSC = CreateObject("ScriptControl")
        objSC.Language = "Jscript"
        sPart(1) = objSC.CodeObject.encodeURIComponent(sPart(1))
        sPart(1) = Replace(sPart(1), "%3D", "=")
        sPart(1) = Replace(sPart(1), "%26", "&")
        Set objSC = Nothing
    End If
    URLEncode = Join(sPart, "?")
End Function
 
Public Function URLDecode(ByVal sUrl As String) As String
    Dim objSC As Object
    Set objSC = CreateObject("ScriptControl")
    objSC.Language = "Jscript"
    URLDecode = objSC.CodeObject.decodeURIComponent(sUrl)
    Set objSC = Nothing
End Function
 

Private Declare Function WideCharToMultiByte Lib "KERNEL32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "KERNEL32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Const CP_UTF8                           As Long = 65001
 
 
Private Sub Form_Load()
Debug.Print (URLEncode("https://www.google.com.ar/search?q=canción"))
Debug.Print URLDecode(URLEncode("https://www.google.com.ar/search?q=canción"))
End Sub
 
 
Function URLEncode(url As String) As String
Dim sp() As Byte
Dim final As String
 
sp() = StrConv(Unicode2UTF8(url), vbFromUnicode)
 
For i = 0 To UBound(sp)
 
Select Case sp(i)
 
    Case 45, 46, 48 To 57, 65 To 90, 95, 97 To 122, 126
         final = final & Chr(sp(i))
 
    Case 32
        final = final & "+"
 
   Case Else
           final = final & "%" & Hex(sp(i))
End Select
 
Next
URLEncode = final
End Function
 
Function URLDecode(url As String) As String
Dim spl() As String
Dim final As String
Dim str As String
str = Replace(url, "+", " ")
spl() = Split(str, "%")
final = spl(0)
For i = 1 To UBound(spl)
final = final & Chr(CLng("&H" & Left(spl(i), 2))) & Mid(spl(i), 3)
Next
URLDecode = UTF82Unicode(final)
End Function
 
 
 
Private Function UTF82Unicode(ByVal sUTF8 As String) As String
 
    Dim UTF8Size As Long
    Dim BufferSize As Long
    Dim BufferUNI As String
    Dim LenUNI As Long
    Dim bUTF8() As Byte
 
    If LenB(sUTF8) = 0 Then Exit Function
 
    bUTF8 = StrConv(sUTF8, vbFromUnicode)
    UTF8Size = UBound(bUTF8) + 1
 
    BufferSize = UTF8Size * 2
    BufferUNI = String$(BufferSize, vbNullChar)
 
    LenUNI = MultiByteToWideChar(CP_UTF8, 0, bUTF8(0), UTF8Size, StrPtr(BufferUNI), BufferSize)
 
    If LenUNI Then
        UTF82Unicode = Left$(BufferUNI, LenUNI)
    End If
 
End Function
 
 
Private Function Unicode2UTF8(ByVal strUnicode As String) As String
 
    Dim LenUNI As Long
    Dim BufferSize As Long
    Dim LenUTF8 As Long
    Dim bUTF8() As Byte
 
    LenUNI = Len(strUnicode)
 
    If LenUNI = 0 Then Exit Function
 
    BufferSize = LenUNI * 3 + 1
    ReDim bUTF8(BufferSize - 1)
 
    LenUTF8 = WideCharToMultiByte(CP_UTF8, 0, StrPtr(strUnicode), LenUNI, bUTF8(0), BufferSize, vbNullString, 0)
 
    If LenUTF8 Then
        ReDim Preserve bUTF8(LenUTF8 - 1)
        Unicode2UTF8 = StrConv(bUTF8, vbUnicode)
    End If
 
End Function
 

'---------------------------------------------------------------------------------------
' Module      : mUrlEncode
' DateTime    : 21/12/2012 - Fin del Mundo!
' Author      : Cobein
' Mail        : cobein27@hotmail.com
' Purpose     : Encode and Decode url parameters
' Requirements: None
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
'---------------------------------------------------------------------------------------
Option Explicit
 
Private Const ICU_ESCAPE                    As Long = &H80000000
Private Const ICU_DECODE                    As Long = &H10000000
Private Const CP_UTF8                       As Long = 65001
Private Const ICU_BROWSER_MODE              As Long = &H2000000
 
Private Type URL_COMPONENTS
    StructSize          As Long
    Scheme              As String
    SchemeLength        As Long
    nScheme             As Long
    HostName            As String
    HostNameLength      As Long
    nPort               As Long
    UserName            As String
    UserNameLength      As Long
    Password            As String
    PasswordLength      As Long
    URLPath             As String
    UrlPathLength       As Long
    ExtraInfo           As String
    ExtraInfoLength     As Long
End Type
 
Private Declare Function InternetCrackUrl Lib "wininet.dll" Alias "InternetCrackUrlA" (ByVal lpszUrl As String, ByVal dwUrlLength As Long, ByVal dwFlags As Long, lpUrlComponents As URL_COMPONENTS) As Long
Private Declare Function InternetCanonicalizeUrl Lib "wininet.dll" Alias "InternetCanonicalizeUrlA" (ByVal lpszUrl As String, ByVal lpszBuffer As String, lpdwBufferLength As Long, ByVal dwFlags As Long) As Long
Private Declare Function InternetCreateUrl Lib "wininet.dll" Alias "InternetCreateUrlA" (lpUrlComponents As URL_COMPONENTS, ByVal dwFlags As Long, ByVal lpszUrl As String, lpdwUrlLength As Long) As Long
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 String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
 
Public Function URLDecode(ByVal sURL As String, _
       Optional ByVal bEncodeSpace As Boolean = False, _
       Optional ByVal bUTF8 As Boolean = True) As String
 
    Dim tURL_COMPONENTS As URL_COMPONENTS
 
    Call CrackUrl(sURL, tURL_COMPONENTS)
 
    If bEncodeSpace Then
        tURL_COMPONENTS.ExtraInfo = Replace(tURL_COMPONENTS.ExtraInfo, "+", " ")
    End If
 
    URLDecode = CreateUrl(tURL_COMPONENTS, False)
 
    If bUTF8 Then
        URLDecode = UTF82Unicode(URLDecode)
    End If
End Function
 
Public Function URLEncode(ByVal sURL As String, _
       Optional ByVal bEncodeSpace As Boolean = False, _
       Optional ByVal bUTF8 As Boolean = True) As String
 
    Dim tURL_COMPONENTS As URL_COMPONENTS
 
    If bUTF8 Then
        sURL = Unicode2UTF8(sURL)
    End If
 
    Call CrackUrl(sURL, tURL_COMPONENTS)
 
    URLEncode = CreateUrl(tURL_COMPONENTS, True)
 
    If bEncodeSpace Then
        URLEncode = Replace(URLEncode, "%20", "+")
    End If
End Function
 
Private Function CreateUrl(ByRef tURL_COMPONENTS As URL_COMPONENTS, ByVal bEscape As Boolean) As String
    Dim sBuffer As String
 
    sBuffer = String$(2048, 0)
 
    tURL_COMPONENTS.StructSize = Len(tURL_COMPONENTS)
 
    If InternetCreateUrl(tURL_COMPONENTS, IIf(bEscape, ICU_ESCAPE, 0), sBuffer, 2048) Then
        CreateUrl = Left$(sBuffer, lstrlen(sBuffer))
    End If
End Function
 
Private Sub CrackUrl(ByVal sURL As String, ByRef tURL_COMPONENTS As URL_COMPONENTS)
    Dim sBuffer As String
    Dim lSize   As Long
 
    lSize = 2048
    sBuffer = Space$(lSize)
 
    If InternetCanonicalizeUrl(sURL, sBuffer, lSize, ICU_BROWSER_MODE) Then
 
        sURL = Left$(sBuffer, lstrlen(sBuffer))
 
        With tURL_COMPONENTS
            .StructSize = Len(tURL_COMPONENTS)
            .Scheme = Space$(lSize)
            .SchemeLength = lSize
            .HostName = Space$(lSize)
            .HostNameLength = lSize
            .UserName = Space$(lSize)
            .UserNameLength = lSize
            .Password = Space$(lSize)
            .PasswordLength = lSize
            .URLPath = Space$(lSize)
            .UrlPathLength = lSize
            .ExtraInfo = Space$(lSize)
            .ExtraInfoLength = lSize
        End With
 
        Call InternetCrackUrl(sURL, Len(sURL), ICU_DECODE, tURL_COMPONENTS)
    End If
End Sub
 
Private Function UTF82Unicode(ByVal sData As String) As String
    Dim lRet    As Long
    Dim sBuffer As String
 
    sBuffer = Space(Len(sData))
 
    lRet = MultiByteToWideChar(CP_UTF8, 0, _
       StrPtr(StrConv(sData, vbFromUnicode)), Len(sData), _
       StrPtr(sBuffer), Len(sData))
 
    If lRet Then
        UTF82Unicode = Left$(sBuffer, lRet)
    End If
End Function
 
Private Function Unicode2UTF8(ByVal sData As String) As String
    Dim lRet    As Long
    Dim sBuffer As String
 
    sBuffer = Space(LenB(sData))
 
    lRet = WideCharToMultiByte(CP_UTF8, 0, _
       StrPtr(sData), Len(sData), _
       StrPtr(sBuffer), Len(sBuffer), _
       vbNullString, 0)
 
    If lRet Then
        sBuffer = StrConv(sBuffer, vbUnicode)
        Unicode2UTF8 = Left$(sBuffer, lRet)
    End If
End Function
 
 

Option Explicit
'============================================================================
' º Module     : mFastUrlEncode.bas
' º Author     : Psyke1
' º Mail       : psyke1@elhacker.net
' º Date       : 22/12/2012
' º Recommended Websites :
'       http://foro.h-sec.org
'       http://infrangelux.sytes.net
'============================================================================
 
'// msvbvm60.dll
Private Declare Sub PutMem4 Lib "msvbvm60.dll" (ByVal Ptr As Long, ByVal Value As Long)
 
'// oleaut32.dll
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal Ptr As Long, ByVal Length As Long) As Long
 
'// kernel32.dll
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (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 String, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
 
Private Const CP_UTF8                           As Long = &HFDE9&
Private Const STR_VALID_CHARS                   As String = "QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm1234567890-_.:~%&="
 
Public Static Function URLEncode(ByVal sUrl As String, _
                                 Optional ByVal bSpacePlus As Boolean, _
                                 Optional ByVal bUTF8 As Boolean = True) As String
 
Dim Q                                           As Long
Dim sHex                                        As String
Dim sChr                                        As String * &H1
Dim lRet                                        As Long
Dim lLen                                        As Long
Dim lStart                                      As Long
Dim sBuffer                                     As String
 
    lLen = LenB(sUrl)
    If lLen Then
        lStart = InStrB(&H1, sUrl, "=", vbBinaryCompare) - &H1
 
        If lStart > -&H1 Then
            lRet = lLen - lStart
            URLEncode = RightB$(sUrl, lRet)
 
            If bUTF8 Then
                PutMem4 VarPtr(sBuffer), SysAllocStringByteLen(&H0, (lRet + lRet))
 
                lRet = WideCharToMultiByte(CP_UTF8, &H0, _
                                           StrPtr(URLEncode), (lRet \ &H2), _
                                           StrPtr(sBuffer), lRet, _
                                           vbNullString, &H0)
 
                URLEncode = LeftB$(StrConv(sBuffer, vbUnicode), (lRet + lRet))
            End If
 
            Q = &H3
 
            Do While Q < lLen
                sChr = MidB$(URLEncode, Q, &H2)
 
                If sChr = "%" Then
                    Q = Q + &H6
                ElseIf InStrB(&H1, STR_VALID_CHARS, sChr, vbBinaryCompare) = &H0 Then
                    sHex = Hex$(AscW(sChr))
                    If LenB(sHex) < &H4 Then sHex = "0" & sHex
 
                    URLEncode = Replace$(URLEncode, sChr, ("%" & sHex), , , vbBinaryCompare)
 
                    lLen = LenB(URLEncode)
                    Q = Q + &H6
                Else
                    Q = Q + &H2
                End If
            Loop
 
            If bSpacePlus Then
                URLEncode = Replace$(URLEncode, "%20", "+", , , vbBinaryCompare)
            End If
 
            URLEncode = (LeftB$(sUrl, lStart) & URLEncode)
        Else
            URLEncode = sUrl
        End If
    End If
End Function
 
Public Static Function URLDecode(ByVal sUrl As String, _
                                 Optional ByVal bSpacePlus As Boolean, _
                                 Optional ByVal bUTF8 As Boolean = True) As String
 
Dim sHex                                        As String
Dim lPos                                        As Long
Dim lLen                                        As Long
Dim lStart                                      As Long
Dim sBuffer                                     As String
 
    If LenB(sUrl) Then
        lStart = InStrB(&H1, sUrl, "=", vbBinaryCompare) + &H2
        URLDecode = sUrl
 
        If lStart > &H2 Then
            lPos = InStrB(lStart, URLDecode, "%", vbBinaryCompare)
 
            Do While lPos
                lPos = lPos + &H2
                sHex = MidB$(URLDecode, lPos, &H4)
                If LenB(sHex) = &H0 Then Exit Do
 
                URLDecode = Replace$(URLDecode, ("%" & sHex), ChrW$("&H" & sHex), , , vbBinaryCompare)
                lPos = InStrB(lPos, URLDecode, "%", vbBinaryCompare)
            Loop
 
            If bSpacePlus Then
                URLDecode = Replace$(URLDecode, "+", " ", , , vbBinaryCompare)
            End If
 
            If bUTF8 Then
                lLen = LenB(URLDecode) \ &H2
                PutMem4 VarPtr(sBuffer), SysAllocStringByteLen(&H0, lLen + lLen)
 
                lLen = MultiByteToWideChar(CP_UTF8, &H0, _
                       StrPtr(StrConv(URLDecode, vbFromUnicode)), lLen, _
                       StrPtr(sBuffer), lLen)
 
                URLDecode = LeftB$(sBuffer, (lLen + lLen))
            End If
        End If
    End If
End Function
 

Option Explicit
 
Private Sub Form_Load()
Dim vURL                                    As Variant
Dim vArr()                                  As Variant
Dim sEncodedURL                             As String
 
    vArr() = Array("https://www.google.com.ar/search?q=canción del caballo", _
                   "http://www.taringa.net/buscar/?q=día 12/12/12&interval=", _
                   "https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http://mail.live.com/default.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1", _
                   "https://www.google.com.ar/search?q=casa duplex&num=10&hl=es&safe=off&biw=1680&bih=925&sa=X&ei=mS7RUIqvHYjW8gSA9oHABg&ved=0CBkQpwUoAw&source=lnt&tbs=cdr:1,cd_min:5/12/2012,cd_max:18/12/2012&tbm=isch")
 
    Debug.Print
    Debug.Print String$(15, "-"); Time$; String$(227, "-")
 
    For Each vURL In vArr
        Debug.Print String$(250, "=")
        Debug.Print "Original :", vURL
 
        sEncodedURL = URLEncode(vURL)
        Debug.Print "Enc&Dec  :", URLDecode(sEncodedURL)
        Debug.Print "Enc      :", sEncodedURL
 
        sEncodedURL = URLEncode(vURL, True)
        Debug.Print "Enc&Dec+ :", URLDecode(sEncodedURL, True)
        Debug.Print "Enc+     :", sEncodedURL
    Next vURL
 
    Debug.Print String$(250, "=")
End Sub

https://www.google.com.ar/search?q=canci%C3%B3n
 

https://www.google.com.ar/search?q=canci%F3n