In Excel 2003 VBA, how to quickly extract a base domain from a given URL?

I.e.

http://www.domain.net/sub1/sub2/etc/page.html
would become
http://www.domain.net/

or...

ftp://ftp.server.net/sub1
would become
ftp://ftp.server.net/

or...

www.website.net
would become
http://www.website.net/

and also secure sites

https://www.securesite.net/index.asp
would become
https://www.securesite.net/

and maybe even

ftp.site.net
would become
ftp://ftp.site.net/



TIA,

Sub main()
Dim s As String, t As String
s = "http://www.domain.net/sub1/sub2/etc/page.html"
t = ural(s)
MsgBox (t)
End Sub

Function ural(inpt As String) As String
Dim sep As String
sep = "/"
t = Split(inpt, sep)
ural = t(0) & sep & sep & t(1) & sep & t(2) & sep
End Function

--
Gary''s Student - gsnu200855


"Charlotte E" wrote:


In Excel 2003 VBA, how to quickly extract a base domain from a given URL?

I.e.

http://www.domain.net/sub1/sub2/etc/page.html
would become
http://www.domain.net/

or...

ftp://ftp.server.net/sub1
would become
ftp://ftp.server.net/

or...

www.website.net
would become
http://www.website.net/

and also secure sites

https://www.securesite.net/index.asp
would become
https://www.securesite.net/

and maybe even

ftp.site.net
would become
ftp://ftp.site.net/



TIA,

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

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)




On Sun, 31 May 2009 11:09:02 +0200, "Charlotte E" <@ wrote:


In Excel 2003 VBA, how to quickly extract a base domain from a given URL?

I.e.

http://www.domain.net/sub1/sub2/etc/page.html
would become
http://www.domain.net/

or...

ftp://ftp.server.net/sub1
would become
ftp://ftp.server.net/

or...

www.website.net
would become
http://www.website.net/

and also secure sites

https://www.securesite.net/index.asp
would become
https://www.securesite.net/

and maybe even

ftp.site.net
would become
ftp://ftp.site.net/



TIA,

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

--
Rick (MVP - Excel)


"Charlotte E" <@ wrote in message ...

In Excel 2003 VBA, how to quickly extract a base domain from a given URL?

I.e.

http://www.domain.net/sub1/sub2/etc/page.html
would become
http://www.domain.net/

or...

ftp://ftp.server.net/sub1
would become
ftp://ftp.server.net/

or...

www.website.net
would become
http://www.website.net/

and also secure sites

https://www.securesite.net/index.asp
would become
https://www.securesite.net/

and maybe even

ftp.site.net
would become
ftp://ftp.site.net/



TIA,

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