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.
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 Stringel segundo parametro es opcional para remplazar espacios por +
es practicamente como lo que hace esta web http://meyerweb.com/eric/tools/dencoder/
osea ingresamos
Citarhttps://www.google.com.ar/search?q=canción
si usamos la funcion urlEncode deberia cambiar el acento
Citarhttps://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
Citarhttp://www.taringa.net/buscar/?q=día 12/12/12&interval=
http://www.taringa.net/buscar/?q=d%C3%ADa%2012%2F12%2F12&interval=
Citarhttps://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.
Encontré errores en el código, así que lo quito.
Cuando lo tenga, lo pongo... :P
Aquí esta el Encode ;D creo que es lo que se quiere, al rato traigo el Decode
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.
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
Leandro no podes usar InternetCanonicalizeUrl ?
http://msdn.microsoft.com/en-us/library/windows/desktop/aa384342(v=vs.85).aspx
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 (http://msdn.microsoft.com/en-us/library/windows/desktop/bb773774(v=vs.85).aspx) pero no codifica los caracteres al igual que cuando los copio de la barra del navegador, de todas formas la url parce andar bien.
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.
Dejo mi Encode. El decode lo hago cuando se pase la F1ACA... ;D
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/ (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... :-\
Tiro una utilizando las funciones de javascript, haciendo unos malabares para preservar una url valida
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
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
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
Cita de: LeandroA en 19 Diciembre 2012, 04:28 AM
@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/
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
HOLA!!!
Como va el reto, asi lo publico en la recopilación.
GRACIAS POR LEER!!!
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$.
'---------------------------------------------------------------------------------------
' 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
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. :silbar:
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:
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:
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:
---------------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! :P
@Psyke1 tu codigo no simula bien lo de la pagina. hace falta convertirla cadena a UTF8.
debe imprimirlo así:
cobein
https://www.google.com.ar/search?q=canci%C3%B3n
el tuyo lo deja así:
Psyke1
https://www.google.com.ar/search?q=canci%F3n
saludos
Ok, se me escapó. :silbar: Gracias, ya lo he corregido.
Ahora tan sólo queda hacer los test con CTiming. :)
DoEvents! :P