VBA Routine Returns URL Anatomy

[Joe Boatman]

What's the anatomy of a URL? Whatever the rules are, it seems you can type many variants into the URL address bar of most browsers and still get the site you wanted! I've also found different names for the various URL parts. Thanks to mattcutts.com for his dissemination.

So I authored a routine that seems to return most of the component parts that I thought I might need, plus an Excel-like COUNTIF function that's not in Access VBA.

My IsVBAHyperlink function is very basic and simply returns True if the code thinks that the URL is in the style of an Access VBA Hyperlink (which has lots of #'s). I'll be posting about the issues when using Hyperlink textboxes...

Access VBA routine which requires no special references
Use GetDomain_TEST to examine how the routine displays each anatomical part of a URL
Requires (included) functions IsVBAHyperlink(), fCountIf()

'14 May 2020
'Returns domain from URL or "" if not valid
'URL parts are returned in the ByRef parameters
'Useful for URL anatomy: https://www.mattcutts.com/blog/seo-glossary-url-definitions/
Function GetDomain(sURL As String, _
    Optional ByRef sProtocol As String, _
    Optional ByRef sSubDomain As String, _
    Optional ByRef sDomain As String, _
    Optional ByRef sEndPath As String) As String

    Dim sRest As String, sTLD As String
    Dim i As Integer, nDotCount As Integer, nPos As Integer
    Dim nEoD As Integer 'End of domain (after Second/Top Level Domain part)
    Dim vArr

    'Clear parameters (from the calling routine)
    sProtocol = ""
    sDomain = ""
    sEndPath = ""

    'Checks
    If IsVBAHyperlink(sURL) = True Then GoTo ExitRoutine
    vArr = VBA.Split(sURL, "//", , vbTextCompare)
    If VBA.IsArray(vArr) = False Then GoTo ExitRoutine

    'Get Protocol
    For i = LBound(vArr) To UBound(vArr)
        If i = LBound(vArr) + 1 Then sRest = vArr(i)
    Next
    If i = 1 Then sRest = vArr(LBound(vArr))
    If sRest = "" Then GoTo ExitRoutine
    If i > 1 Then sProtocol = vArr(0) & "//"

    'Get the rest
    vArr = VBA.Split(sRest, ".", , vbTextCompare)
    nDotCount = UBound(vArr) - LBound(vArr)
    For i = UBound(vArr) To LBound(vArr) Step -1
        Select Case i
            Case nDotCount
            sRest = vArr(nDotCount)

            Case 3
            sEndPath = vArr(3)

            Case 2
            sDomain = vArr(2)

            Case 1
            sDomain = vArr(1)

            Case 0
            If sDomain = "" Then
                sDomain = vArr(0)
            Else
                sSubDomain = vArr(0)
            End If

        End Select
    Next

    'Get the end path (bit after '/')
    nPos = VBA.InStr(1, sRest, "/", vbTextCompare)
    'nPos = VBA.InStr(1, sURL, "/", vbTextCompare)
    If nPos > 0 Then
        sEndPath = VBA.Mid$(sRest, nPos)    'Start of rest of URL after domain & TLD
        nEoD = nPos - 1
        sTLD = "." & VBA.Left$(sRest, nPos - 1)
    ElseIf nPos = 0 Then
        nPos = VBA.InStr(1, sURL, sDomain, vbTextCompare) + VBA.Len(sDomain)
        sRest = VBA.Mid$(sURL, nPos)
        sTLD = sRest
    End If

    'Build domain name (incl SLD & TLD)
    sDomain = sDomain & sTLD

    vArr = Empty

ExitRoutine:
    GetDomain = sDomain
End Function
Private Sub GetDomain_TEST()
    Dim sRetVal As String, sProtocol As String, sSubDomain As String, sDomain As String, sEndPath As String

    sRetVal = GetDomain("https://blog.hubspot.com/marketing/parts-url", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("www.bbc.com", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("bbc.co.uk", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("https://www.bbc.com", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("https://www.google.com/maps", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("https://maps.google.co.uk", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("https://www3.royalmail.com/track-your-item#/tracking-results/WM936716905GB", sProtocol, sSubDomain, sDomain, sEndPath)
    sRetVal = GetDomain("")
End Sub


'~~~~~~~~~~~ Support Routines

'14 May 2020
'Returns True if sData is a VBA-style hyperlink. If False, sData could still be a valid URL
'VBA hyperlink is displaytext#address#subaddress#screentip
'Not a fantastic comprehensive routine!
Function IsVBAHyperlink(sData As String) As Boolean

    Dim sDomain As String
    Dim nHashCount As Integer
    Dim bRetVal As Boolean

    nHashCount = fCountIf(sData, "#")
    If nHashCount = 0 Then GoTo ExitRoutine
    bRetVal = (nHashCount > 1)

'    sDomain = GetDomain(sData)
'    If sDomain = "" Then GoTo ExitRoutine

ExitRoutine:
    IsVBAHyperlink = bRetVal
End Function



'14 Aug 2019
Function fCountIf(sString As String, sFindChr As String) As Integer
'Return the number of chrs in sString
'Called by apCSV_ConvertLine_TEST, IsVBAHyperlink

    Dim nPos As Integer, i As Integer, nCount As Integer

    For i = 1 To VBA.Len(sString)
        If VBA.Mid$(sString, i, 1) = sFindChr Then nCount = nCount + 1
    Next
    fCountIf = nCount

End Function