|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (ActiveX/Controles/DLL)
|
|
 |
Título da Dica: Função que retorna vários componentes de uma URL ""host", "port", "user", "pass", "path" e "query"
|
 |
|
|
|
Postada em 13/3/2004 por Josefh Hennyere
'Módulo.bas
Public Type typURL 'http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage
Protocol As String 'contains the protocol if specified (e.g. http://, ftp:// etc.)
ServerName As String 'contains the servername (e.g. proxy.spiderit.net)
Filename As String 'contains the filename (e.g. proxycfg.php3)
Dir As String 'contains the directory (e.g. /prox/)
Filepath As String 'contains the whole filepath (e.g. /prox/proxycfg.php3)
Username As String 'contains the username (e.g. sit)
Password As String 'contains the password (e.g. sitter)
Query As String 'contains the querystring (e.g. openpage)
ServerPort As Integer 'contains the serverport (e.g. 881)
End Type
Public Const strNOCONTENT As String = "NOCONTENT"
Public Const intDEFAULTPORT As Integer = 80
Function ParseURL(URL As String) As typURL
Dim strTemp As String
Dim strServerAuth As String
Dim strServerNPort As String
Dim strAuth As String
strTemp = URL
'********
'- Parse protocol
If (InStr(1, strTemp, "://") > 0) Then
'URL contains protocol
ParseURL.Protocol = Left(strTemp, InStr(1, strTemp, "://") - 1)
strTemp = Right(strTemp, Len(strTemp) - (Len(ParseURL.Protocol) + 3)) 'delete protocol + ://
Else
'URL do not contains the protocol
ParseURL.Protocol = strNOCONTENT
End If
'********
'- Parse authenticate information
If (InStr(1, strTemp, "/") > 0) Then
'extract servername and user and password if there are directory infos
strServerAuth = Left(strTemp, InStr(1, strTemp, "/") - 1)
strTemp = Right(strTemp, Len(strTemp) - (Len(strServerAuth) + 1))
Else
'extract servername and user and password if there are no directory infos
strServerAuth = strTemp
strTemp = "/"
End If
If (InStr(1, strServerAuth, "@") > 0) Then
'there are user and password informations
strAuth = Left(strServerAuth, InStr(1, strServerAuth, "@") - 1)
strServerNPort = Right(strServerAuth, Len(strServerAuth) - (Len(strAuth) + 1))
Else
'there are no user and password informations
strAuth = ""
strServerNPort = strServerAuth
End If
If (InStr(1, strAuth, ":") > 0) And (Len(strAuth) > 0) Then
'split username and password on ":" splitter
ParseURL.Username = Left(strAuth, InStr(1, strAuth, ":") - 1)
ParseURL.Password = Right(strAuth, Len(strAuth) - InStr(1, strAuth, ":"))
ElseIf (InStr(1, strAuth, ":") <= 0) And (Len(strAuth) > 0) Then
'only username was submitted
ParseURL.Username = strAuth
ParseURL.Password = strNOCONTENT
Else
'no authenticate information was submitted
ParseURL.Username = strNOCONTENT
ParseURL.Password = strNOCONTENT
End If
If (InStr(1, strServerNPort, ":") > 0) Then
'Servername contains port
ParseURL.ServerPort = Int(Right(strServerNPort, Len(strServerNPort) - InStr(1, strServerNPort, ":")))
ParseURL.ServerName = Left(strServerNPort, InStr(1, strServerNPort, ":") - 1)
Else
ParseURL.ServerPort = intDEFAULTPORT
ParseURL.ServerName = strServerNPort
End If
If (InStr(1, strTemp, "?") > 0) Then
ParseURL.Query = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "?"))
strTemp = Left(strTemp, InStr(1, strTemp, "?") - 1)
Else
ParseURL.Query = strNOCONTENT
End If
For i = Len(strTemp) To 1 Step -1
If (Mid(strTemp, i, 1) = "/") Then
ParseURL.Filename = Right(strTemp, Len(strTemp) - i)
ParseURL.Dir = Left(strTemp, i)
If Not (Left(ParseURL.Dir, 1) = "/") Then
ParseURL.Dir = "/" & ParseURL.Dir
End If
Exit For
End If
Next
ParseURL.Filepath = "/" & strTemp
If Not (Left(ParseURL.Filepath, 1) = "/") Then
ParseURL.Filepath = "/" & ParseURL.Filepath
End If
End Function
'No load do formulário
Private Sub Form_Load()
Const strURL As String = "http://www.jhsmdesigners.kit.net/downloads/msxccv1.1_2000.rar"
msgtext = ParseURL(strURL).Protocol & vbCrLf
msgtext = msgtext & ParseURL(strURL).Username & vbCrLf
msgtext = msgtext & ParseURL(strURL).Password & vbCrLf
msgtext = msgtext & ParseURL(strURL).ServerName & vbCrLf
msgtext = msgtext & ParseURL(strURL).ServerPort & vbCrLf
msgtext = msgtext & ParseURL(strURL).Filepath & vbCrLf
msgtext = msgtext & ParseURL(strURL).Dir & vbCrLf
msgtext = msgtext & ParseURL(strURL).Filename & vbCrLf
msgtext = msgtext & ParseURL(strURL).Query & vbCrLf
MsgBox msgtext, vbInformation
End Sub
'É só testar
|
|
|
|
|
