USUÁRIO:      SENHA:        SALVAR LOGIN ?    Adicione o VBWEB na sua lista de favoritos   Fale conosco 

 

  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
 


CyberWEB Network Ltda.    © Copyright 2000-2021   -   Todos os direitos reservados.
Powered by HostingZone - A melhor hospedagem para seu site
Topo da página