< Public Function GetPartOfURL (ByVal URL As String, Options As Integer) As String (?)

Comments

    
    '------------------------------------------------------------------------------
    'GetPartOfURL(URL As String, Options As Integer) As String
    '------------------------------------------------------------------------------
    'Takes a URL, and returns either a selected part
    '(domain name, file extension etc) or a list of all parts
    ' Options:
    '   0: Return unchanged URL
    '   1: Protocol
    '   2: Domain, removing the www
    '   3: Domain
    '   4: Directory
    '   5: Filename
    '   6: Filename stem
    '   7: Filename extension
    '   8: Query
    '   -1: Return a newline-separated list of all the above
    'e.g.
    '   http://www.blibbleblobble.co.uk/News/Articles/index.php?referredfrom=\2s
    ' 1 ####
    ' 2            ####################
    ' 3        ########################
    ' 4                                ###############
    ' 5                                               #########
    ' 6                                               #####
    ' 7                                                     ###
    ' 8                                                         ################
    '
    ' Copyright Oliver White, 2001 - GNU GPL license (see gnu.org for details)
    '------------------------------------------------------------------------------

Public Function GetPartOfURL (ByVal URL As String, Options As Integer) As String

        
        
    Dim Pos As Integer
    Dim Section(-1 To 10) As String
    Dim i As Integer
    
    'Get protocol from front
    Section(0) = URL
    Pos = InStr(1, URL, ":")
    If Pos > 1 Then
        Section(1) = Left(URL, Pos - 1)
        URL = TrimFrom(URL, Pos, 0)
    End If
        
    
    If Left(URL, 2) = "//" Then
        URL = TrimFrom(URL, 2, 0)
    End If
    
    'Get domain from front
    Pos = InStr(1, URL, "/")
    If Pos > 1 Then
        Section(3) = Left(URL, Pos - 1)
        URL = TrimFrom(URL, Pos - 1, 0)
    Else
        Section(3) = URL
        URL = ""
    End If
    
    'Remove the www part of a domain
    If Left(Section(3), 4) = "www." Then
        Section(2) = TrimFrom(Section(3), 4, 0)
    Else
        Section(2) = Section(3)
    End If
    
    'Get query from back
    Pos = InStrRev(URL, "?")
    If Pos > 0 Then
        Section(8) = Right(URL, Len(URL) - Pos)
        URL = TrimFrom(URL, 0, Len(URL) - Pos + 1)
    End If
    
    'Get filename from back
    Pos = InStrRev(URL, "/")
    If Pos > 0 Then
        Section(5) = Right(URL, Len(URL) - Pos)
        Section(4) = Left(URL, Pos)
    End If
    
    'Get stem and extension from filename
    Pos = InStr(Section(5), ".")
    If Pos > 0 Then
        Section(6) = Left(Section(5), Pos - 1)
        Section(7) = Right(Section(5), Len(Section(5)) - Pos)
    End If
    
    'Compile the newline-separated list of the above
    If Options = -1 Then
        For i = 0 To UBound(Section)
            Section(-1) = Section(-1) & Section(i) & vbCrLf
        Next
    End If
    
    'Return data
    GetPartOfURL = Section(Options)
End Function

Copying, Return to index