Extract base domain from an URL?

1

1ifesco1ar

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
 
C

Chip Pearson

Try some code like the following. It will parse URLs with the
following formats:

www.cpearson.com
www.cpearson.com/Page.aspx
www.cpearson.com/Page.aspx?param=1234
www.cpearson.com?param=1234
http://www.cpearson.com
http://www.cpearson.com/Page.aspx
http://www.cpearson.com/Page.aspx?param=1234
http://www.cpearson.com?param=1234

In all cases, it will retrun www.cpearson.com prefixed with "http://"
if that was present in the original URL.


Dim URL As String
Dim N As Long
Dim M As Long
Dim S As String

URL = "http://www.cpearson.com"
N = InStr(1, URL, "//") + 2
M = InStr(N, URL, "?")
N = InStr(N, URL, "/")
If N = 0 Then
If M = 0 Then
S = URL
Else
S = Left(URL, M - 1)
End If
Else
If M = 0 Then
S = Left(URL, N - 1)
Else
If M < N Then
S = Left(URL, M - 1)
Else
S = Left(URL, N - 1)
End If
End If
End If
Debug.Print S


Cordially,
Chip Pearson
Microsoft Most Valuable Professional
Excel Product Group, 1998 - 2009
Pearson Software Consulting, LLC
www.cpearson.com
(email on web site)
 
R

Rick Rothstein

Here is my attempt at a function for you...

Function BaseAddress(S As String) As String
Dim Parts() As String
Parts = Split(S, "://")
BaseAddress = Left(S, InStr(S, "://")) & "//" & Split(Parts(Abs(UBound(Parts) > 0)), "/")(0)
If BaseAddress Like "//*" Then
BaseAddress = Mid("htf", 1 - 2 * (Split(S, ".")(0) = "ftp"), 2) & "tp:" & BaseAddress
End If
End Function
 
Top