[Reto] UrlEncode y UrlDecode

[LeandroA]

Hola, se me presento la necesidad de crear esas funciones y en la web encontré algunas pero no funcionan muy bien asi que me pareció interesante el reto, no es muy dificil (creo), pero es para ver quien las puede hacer funcionar mas rapido.

Código [Seleccionar] Expandir

Public Function URLDecode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
Public Function URLEncode(ByVal sURL As String, Optional ByVal SpacePlus As Boolean = True) As String
el segundo parametro es opcional para remplazar espacios por +

es practicamente como lo que hace esta web http://meyerweb.com/eric/tools/dencoder/



osea ingresamos

https://www.google.com.ar/search?q=canción

si usamos la funcion urlEncode deberia cambiar el acento

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

por lo visto esta pasado a utf8 y luego a hex
lo importante es que encode los parámetros no la url entera ya que sino dejaria de ser una url valida.

otro ejemplos

http://www.taringa.net/buscar/?q=día 12/12/12&interval=
http://www.taringa.net/buscar/?q=d%C3%ADa%2012%2F12%2F12&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://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http:%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1

después iremos debatiendo que esta mal o que falta.

[MCKSys Argentina]

Encontré errores en el código, así que lo quito.

Cuando lo tenga, lo pongo... 

[Danyfirex]

Aquí esta el Encode   creo que es lo que se quiere, al rato traigo el Decode

Código (vb) [Seleccionar] Expandir

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

Edito:

aqui esta el Decode.

Código (vb) [Seleccionar] Expandir

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

saludos

PD: lo hice a base de uno que vi en Autoit

[cobein]

Leandro no podes usar InternetCanonicalizeUrl ?

http://msdn.microsoft.com/en-us/library/windows/desktop/aa384342(v=vs.85).aspx

[LeandroA]

bien, ya estoy algo confuso, cobein probé con InternetCanonicalizeUrl no se si pueda decir si funciona o no es algo que no me queda claro, el api trabaja igual que  UrlEscape pero no codifica los caracteres al igual que cuando los copio de la barra del navegador, de todas formas la url parce andar bien.

Código (vb) [Seleccionar] Expandir


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


@Danyfirex la función no va por mal camino pero al remplazar los "&" la url queda inservible.

[MCKSys Argentina]

Dejo mi Encode. El decode lo hago cuando se pase la F1ACA...  

Código (vb) [Seleccionar] Expandir


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


EDIT: El código para parsear el URL lo saqué de acá: http://www.motobit.com/tips/detpg_CrackURL/

EDIT 2: Una cosa que noto ahora es que si la parte de los querys tiene "&" ó "=" demás, el parseo va a fallar... 

[LeandroA]

Tiro una utilizando las funciones de javascript, haciendo unos malabares para preservar una url valida

Código (VB) [Seleccionar] Expandir

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


PD utiliza coficiación utf8
alguien sabe si CreateObject("ScriptControl") es valido para una pc que no tenga instaldo el vb?, o es una libreria que trae  windows

[cobein]

Leandro aca arme un funcion que replica lo que hace la web que posteaste. Las funciones para UTF8 las saque de tu code.

Hay que limpiar ese code porque quedo medio desastre pero bueno es simplemente a modo de ejemplo.

Nota: los caracteres reservados los saque de http://en.wikipedia.org/wiki/Percent-encoding

Código [Seleccionar] Expandir

Option Explicit

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 (EncodeURL("http://www.taringa.net/buscar/?q=día 12/12/12&interval="))
End Sub

Private Function EncodeURL(ByVal sURL As String) As String
   Dim bvData()    As Byte
   Dim i           As Long
   Dim sChar       As String * 1
   
   bvData = Unicode2UTF8(sURL)
   
   For i = 0 To UBound(bvData) Step 2
       sChar = Chr$(bvData(i))
       Select Case sChar
           Case "a" To "z", "A" To "Z", "0" To "9", "-", "_", ".", "~"
               EncodeURL = EncodeURL & sChar
           Case Else
               EncodeURL = EncodeURL & "%" & Right$("0" & Hex(Asc(sChar)), 2)
       End Select
   Next
End Function

Private Function DecodeURL(ByVal sURL As String) As String
   Dim bvData()    As Byte
   Dim i           As Long
   Dim sChar       As String * 1
   bvData = sURL
       
   For i = 0 To UBound(bvData) Step 2
       sChar = Chr$(bvData(i))
       If sChar = "%" Then
           DecodeURL = DecodeURL & Chr$(Val("&h" & Chr$(bvData(i + 2)) & Chr$(bvData(i + 4))))
           i = i + 4
       Else
       DecodeURL = DecodeURL & sChar
       End If
   Next
   DecodeURL = UTF82Unicode(DecodeURL)
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


[Danyfirex]

@Danyfirex la función no va por mal camino pero al remplazar los "&" la url queda inservible.

No entiendo eso Que me dices? :S

igual aquí dejo un poco optimizada la función agregando Las funciones para UTF8.

Y ahora si simula bien como la pagina. http://meyerweb.com/eric/tools/dencoder/

Código (vb) [Seleccionar] Expandir

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


saludos

[79137913]

HOLA!!!

Como va el reto, asi lo publico en la recopilación.

GRACIAS POR LEER!!!