[VB6] URL/Path String Manipulation Functions

[penagate]

Some functions for manipulating strings containing URLs and local file addresses.

Get parent address
Returns the parent address from a URL. e.g.

?GetParentAddress("http://www.domain.com/parentdirectory/subdirectory/")
http://www.domain.com/parentdirectory

Public Function GetParentAddress(ByVal Address As String) As String
    Dim lngCharCount    As Long
    Dim lngBCount       As Long
    Dim strOutput       As String
 
    strOutput$ = Replace(Address, "\", "/")
    lngCharCount = Len(strOutput)
 
    If (Right$(strOutput, 1) = "/") Then strOutput = Left$(strOutput, lngCharCount - 1)
 
    lngCharCount = Len(strOutput)
 
    strOutput = Left$(strOutput, lngCharCount - lngBCount)
    strOutput = Left$(strOutput, InStrRev(strOutput, "/", , vbTextCompare) - 1)
 
    GetParentAddress = strOutput
End Function

Get domain name
Returns the domain name from a URL. e.g.

?GetDomainName("http://www.domain.com/directory/page.html")
www.domain.com

Public Function GetDomainName(ByVal Address As String) As String
    Dim strOutput       As String
    Dim strTemp         As String
    Dim lngLoopCount    As Long
    Dim lngBCount       As Long
    Dim lngCharCount    As Long
 
    strOutput$ = Replace(Address, "\", "/")
    lngCharCount = Len(strOutput)
 
    If (InStrB(1, strOutput, "/")) Then
        Do Until ((strTemp = "/") Or (lngLoopCount = lngCharCount))
            lngLoopCount = lngLoopCount + 1
            strTemp = Mid$(strOutput, lngBCount + 1, 1)
            lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Right$(strOutput, Len(strOutput) - lngBCount)
    lngBCount = 0
    strTemp = "/"
 
    If (InStrB(1, strOutput, "/")) Then
        Do Until strTemp <> "/"
            strTemp = Mid$(strOutput, lngBCount + 1, 1)
            If strTemp = "/" Then lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Right$(strOutput, Len(strOutput) - lngBCount)
    strOutput = Left$(strOutput, InStr(1, strOutput, "/", vbTextCompare) - 1)
 
    GetDomainName = strOutput
End Function

Canonicalize a URL
Returns the canonicalized (friendly) version of the URL. e.g.

?URLCanonicalize("http://www.domain.com/directory/page.html/")
www.domain.com/directory/page.html

Public Function URLCanonicalize(ByVal pstrAddress As String) As String
    Dim strOutput       As String
    Dim strTemp         As String
    Dim lngLoopCount    As Long
    Dim lngBCount       As Long
    Dim lngCharCount    As Long
 
    strOutput$ = Replace(pstrAddress, "\", "/")
    lngCharCount = Len(strOutput)
 
    If (InStrB(1, strOutput, "/")) Then
        Do Until ((strTemp = "/") Or (lngLoopCount = lngCharCount))
            lngLoopCount = lngLoopCount + 1
            strTemp = Mid$(strOutput, lngBCount + 1, 1)
            lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Right$(strOutput, Len(strOutput) - lngBCount)
    lngBCount = 0
    strTemp = "/"
 
    If (InStrB(1, strOutput, "/")) Then
        Do Until (strTemp <> "/")
            strTemp = Mid$(strOutput, lngBCount + 1, 1)
            If strTemp = "/" Then lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Right$(strOutput, Len(strOutput) - lngBCount)
    lngBCount = 0
    strTemp = "/"
    lngCharCount = Len(strOutput)
        If (InStrB(1, strOutput, "/")) Then
        Do Until (strTemp <> "/")
            strTemp = Mid$(strOutput, lngCharCount - lngBCount, 1)
            If strTemp = "/" Then lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Left$(strOutput, Len(strOutput) - lngBCount)
    strOutput = Replace(strOutput, "%20", " ")
 
    URLCanonicalize = strOutput
End Function

Remove illegal characters
Returns the same address minus any characters not allowed in a Windows filename. e.g.

?RemoveIllegals("Some *file* name/thing!")
Some file namething!

Public Function RemoveIllegals(ByVal pstrCheckString As String) As String
    Dim i               As Long
    Dim strOutput       As String
    Dim astrIllegals(8) As String
 
    strOutput = pstrCheckString
 
    astrIllegals(0) = "*"
    astrIllegals(1) = "?"
    astrIllegals(2) = "/"
    astrIllegals(3) = "\"
    astrIllegals(4) = ":"
    astrIllegals(5) = "|"
    astrIllegals(6) = "<"
    astrIllegals(7) = ">"
    astrIllegals(8) = Chr$(34)
 
    For i = 0 To 8
        strOutput = Replace(strOutput, astrIllegals(i), vbNullString)
    Next i
 
    RemoveIllegals = strOutput
End Function

Remove root name or get lowest level name
Returns either the address minus path root, or the lowest-level identifier. e.g.

?RemoveRootName("http://www.domain.com/parentdirectory/subdirectory/", False)
parentdirectory/subdirectory

?RemoveRootName("http://www.domain.com/parentdirectory/subdirectory/", True)
subdirectory

Public Function RemoveRootName(ByVal pstrPath As String, _
                               ByVal pblnGetLowestLevelName As Boolean) _
                              As String
 
    Dim strOutput       As String
    Dim lngLoopCount    As Long
    Dim lngBCount       As Long
    Dim lngCharCount    As Long
    Dim strTemp         As String
 
    strOutput = Replace(pstrPath, "\", "/")
    lngCharCount = Len(strOutput)
 
    If (InStrB(1, strOutput, "/")) Then
        Do Until ((strTemp = "/") Or (lngLoopCount = lngCharCount))
            lngLoopCount = lngLoopCount + 1
            strTemp = Mid$(strOutput, lngBCount + 1, 1)
            lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Right$(strOutput, Len(strOutput) - lngBCount)
    lngBCount = 0
    strTemp = "/"
    If (InStrB(1, strOutput, "/")) Then
        Do Until (strTemp <> "/")
            strTemp = Mid$(strOutput, lngBCount + 1, 1)
            If strTemp = "/" Then lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Right$(strOutput, Len(strOutput) - lngBCount)
    lngBCount = 0
    strTemp = "/"
    lngCharCount = Len(strOutput)
 
    If (InStrB(1, strOutput, "/")) Then
        Do Until (strTemp <> "/")
            strTemp = Mid$(strOutput, lngCharCount - lngBCount, 1)
            If strTemp = "/" Then lngBCount = lngBCount + 1
        Loop
    End If
 
    strOutput = Left$(strOutput, Len(strOutput) - lngBCount)
    strOutput = Right$(strOutput, Len(strOutput) - InStr(1, strOutput, "/", vbTextCompare))
 
    If (pblnGetLowestLevelName) Then _
        strOutput = Right$(strOutput, Len(strOutput) - InStrRev(strOutput, "/"))
 
    strOutput = Replace(strOutput, "%20", " ")
 
    RemoveRootName = strOutput
End Function

Resolve environment variables
Returns the path with any environment variables %environ% resolved. e.g.

?ResolveEnvirons("%systemroot%\Fonts")
C:\WINDOWS\Fonts

Public Function ResolveEnvirons(ByVal pstrText As String) As String
    Dim i                   As Long
    Dim bOpenMarker         As Boolean
    Dim lngLeftMarkerPos    As Long
    Dim strTemp             As String
    Dim strResolveString    As String
    Dim strTextLeft         As String
    Dim strTextRight        As String
 
    For i = 0 To Len(pstrText)
        strTemp = Right$(Left$(pstrText, i), 1)
 
        If (strTemp = "%") Then
            If Not (bOpenMarker) Then
                bOpenMarker = True
                lngLeftMarkerPos = i
 
              Else
                bOpenMarker = False
                strResolveString = Left$(Right$(pstrText, Len(pstrText) - lngLeftMarkerPos), i - lngLeftMarkerPos - 1)
 
                strTextLeft = Left$(pstrText, lngLeftMarkerPos - 1)
                strTextRight = Right$(pstrText, Len(pstrText) - i)
 
                strResolveString = Environ(strResolveString)
 
                pstrText = strTextLeft & strResolveString & strTextRight
                i = -1
            End If
        End If
    Next i
 
    ResolveEnvirons = pstrText
End Function