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