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
Mostrar Mensajes
) que esto es en 64 bits, por ende VB6 queda descartado (el código C crea un thread remoto en el taskman y hace otras cosas que desde 32 bits no se puede hacer; o bien, no sé hacer).
