ExcelBanter - View Single Post

Charlotte E

Thanks to all of you :-)

I got it working :-)

wrote:
Function GetBaseDomain(URL As String) As Variant

Dim schEndPos As Integer
Dim schemeName As String
Dim NakedURL As String
Dim firstSlash As Integer

' refer to http://en.wikipedia.org/wiki/URI_scheme for terminology
' this version only works for URLs where the scheme name is
followed by '//'
' i.e. will not work for about: and mailto: type schemes

' check for presence of scheme name and infer if missing
' always terminates in ':'
schEndPos = InStr(URL, "://")
If schEndPos 0 Then
' there is a scheme name
schemeName = Left(URL, schEndPos + 2)
NakedURL = Right(URL, Len(URL) - schEndPos - 2)
Else
' no scheme name, so infer it
NakedURL = URL
If Left(URL, 4) = "ftp." Then
schemeName = "ftp://"
Else
schemeName = "http://"
End If
End If

' read naked URL as far as first '/' character
firstSlash = InStr(NakedURL, "/")
If firstSlash = 0 Then
' append '/'
NakedURL = NakedURL & "/"
Else
'strip up to first '/'
NakedURL = Left(NakedURL, firstSlash)
End If

GetBaseDomain = schemeName & NakedURL

End Function