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

Private Sub Form_Load()
Const strURL As String = "http://web:logon@intranet.q-tec.org:89/euro/rechner/euro.php3?startpage"
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