[Reto] UrlEncode y UrlDecode

[cobein]

Bueno ahi esta con APIs, lo unico que vi que no es igual a lo que pedis es que las barras en los parametros no las codifica... no se, en teoria codifica lo necesario segun M$.

Código (vb) [Seleccionar] Expandir


'---------------------------------------------------------------------------------------
' 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



[Psyke1]

Bueno, aquí dejo mi forma de hacerlo.
Lo he planteado de una manera un poco diferente y es bastante rápido. Aún así, quizás se podría agilizar aún más con algo de magia negra, pero como la cadena de la url va a ser relativamente corta supongo que no habrá una diferencia muy notable.
Si veis cosas a añadir o a mejorar decirlo, aunque creo que se adapta a lo que pide LeandroA en el primer post.



Módulo:

Código (vb) [Seleccionar] Expandir

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




Pruebas:

Código (vb) [Seleccionar] Expandir

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



Resultado:

Código [Seleccionar] Expandir


---------------01:55:53-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
==========================================================================================================================================================================================================================================================
Original :    https://www.google.com.ar/search?q=canción del caballo
Enc&Dec  :    https://www.google.com.ar/search?q=canción del caballo
Enc      :    https://www.google.com.ar/search?q=canci%C3%B3n%20del%20caballo
Enc&Dec+ :    https://www.google.com.ar/search?q=canción del caballo
Enc+     :    https://www.google.com.ar/search?q=canci%C3%B3n+del+caballo
==========================================================================================================================================================================================================================================================
Original :    http://www.taringa.net/buscar/?q=día 12/12/12&interval=
Enc&Dec  :    http://www.taringa.net/buscar/?q=día 12/12/12&interval=
Enc      :    http://www.taringa.net/buscar/?q=d%C3%ADa%2012%2F12%2F12&interval=
Enc&Dec+ :    http://www.taringa.net/buscar/?q=día 12/12/12&interval=
Enc+     :    http://www.taringa.net/buscar/?q=d%C3%ADa+12%2F12%2F12&interval=
==========================================================================================================================================================================================================================================================
Original :    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
Enc&Dec  :    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
Enc      :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http%3A%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
Enc&Dec+ :    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
Enc+     :    https://login.live.com/login.srf?wa=wsignin1.0&rpsnv=11&ct=1312101221&rver=6.1.6206.0&wp=MBI&wreply=http%3A%2F%2Fmail.live.com%2Fdefault.aspx&lc=2058&id=64855&mkt=es-US&cbcxt=mai&snsc=1
==========================================================================================================================================================================================================================================================
Original :    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
Enc&Dec  :    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
Enc      :    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
Enc&Dec+ :    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
Enc+     :    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%3A1%2Ccd_min%3A5%2F12%2F2012%2Ccd_max%3A18%2F12%2F2012&tbm=isch
==========================================================================================================================================================================================================================================================


DoEvents!

[Danyfirex]

@Psyke1 tu codigo no simula bien lo de la pagina. hace falta convertirla cadena a UTF8.

debe imprimirlo así:
cobein

Código (vb) [Seleccionar] Expandir

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

el tuyo lo deja así:
Psyke1

Código (vbnet) [Seleccionar] Expandir

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

saludos

[Psyke1]

Ok, se me escapó. Gracias, ya lo he corregido.
Ahora tan sólo queda hacer los test con CTiming.

DoEvents!