SharePoint Email's Links Extraction

Introduction

We subscribe to a few SharePoint servers' web pages (multiple sites and pages) and we receive notifications from them whenever they update file contents (daily, and a lot). Converting a list of file names and paths recursively and adding them into a tree is quite simple if you're using a tree control or tabs and spaces. Unfortunately, converting it to HTML proved to be annoying since figuring out correct positions for the closing HTML tags was a bit complicated.

Using the Code

Prerequisites

To enable this code and to read all the hyperlinks, two things have to be enabled:

• In Microsoft Visual Basic for Applications, under Tools | References, enable Microsoft VBScript Regular Expressions 5.5.
• In Microsoft Visual Basic for Applications, under Tools | References, enable Microsoft Word 16.0 Object Library.

Limitations

• An error may appear stating that "Your server administrator has limited the number of items you can open simultaneously." This limits searching Outlook folders to 250 emails.
• Select the MS Outlook emails that you wish to extract the hyperlinks from. This only works on the desktop version of MS Outlook.
• Unfortunately, we don't always have access to the files, and some folders are empty, but we get the same notifications for files and folders. There's no way to check if the last node is a file with no extension or a folder with a period.

MS Outlook VBA

• In MS Outlook, go to File | Options | Customize Ribbon and enable the Developer tab on the right-hand side.
• In MS Outlook, go to File | Options | Trust Center | Trust Center Settings | Macro Settings and select Notifications for all macros.
• Under the Developer tab in MS Outlook, select Visual Basic and open the ThisOutlookSession document. Copy and paste the source code into the ThisOutlookSession document and then save it. When closing MS Outlook, it may prompt you to save it again.

Code Structure

The code consists of two functions and two subroutines.

• Function GetBoiler is used at the end of the GetURLLinks function to add your signature to the email.
• Sub GetSite1Links is what's called to extract all hyperlinks from the SITE1 server.
• Sub GetSite2Links is what's called to extract all hyperlinks from the SITE2 server.
• Function GetURLLinks is where all the madness happens.
  • Create the email template.
  • Get all hyperlinks from all emails (up to 250 emails).
  • Only add hyperlinks from the Site URL (in case you accidentally included a wrong email).
  • Only add hyperlinks that begin with "View " (space included).
    • Do not add if this hyperlink was previously added or it is a directory path that exists.
    • There are several hyperlinks in each email. The only ones that we're interested in are always preceded with "View " in the text. I'm not sure if this is customizable in SharePoint, so you may have to change this part. In retrospect, I could have made it a variable.
  • Sort the hyperlinks alphabetically (case-insensitive). This way, when we build our tree, we're halfway there.
  • Display linked files in HTML structures.
    • ReDim all directory paths to the deepest directory path. This makes it easier to loop through all the path directories.
    • While traversing the paths, save the parent level (as string) and own level (as integer) separately. This allows own level to be incremented easily. The parent level string is a concatenation of the last common parent level and the next own level number with a period as a delimeter (P.O for simplicity).
      • The first own element is set to one for all levels.
      • The first parent element is set to one for all levels.
      • Check if the current node's parent level (P.O) and the previous node's parent level (P.O) are the same.
      • If the current node path is the same as the previous node path, set the new own level to the previous one. Else, increment it by one.
      • If the previous node is unrelated, reset the new own level to one; and append the current node's own level to the parent level.
    • The next step is to build the HTML code with the paths and hyperlinks. The hyperlinks are only added to the files and not to the folder structures. The folder names are bolded. This is done in three loops: (1) opening tags, (2) adding hyperlinked files, and (3) closing tags.
      • Opening Tags
        • For the very first node, we open a UL and LI tag.
        • For each subsequent node, if the P.O of the current node is not equal to the P.O of the previous node and the own level is one, open a UL tag. Open an LI tag for each subsequent node.
      • Adding Hyperlinked Files
        • If the current node is the root node, open a UL tag. Else if the current node is not the root node and the current node's parent level is not equal to the previous node's parent level, open a UL tag.
        • Add the hyperlinked file in an LI tag
        • If the current node is the leaf node, close a UL tag. Else if the current node is not the leaf node and the current node's parent level is not equal to the next node's parent level, close a UL tag.
      • Closing Tags
        • If the current node is the leaf node, close an LI and UL tag. Else if the current node's parent level is not equal to the next node's parent level, close an LI and UL tag. Else if the current node's own level is not equal to the next node's own level, close only an LI tag. The last one indicates that the next file belongs to the same directory as the current file.
        • All UL tags are closed when no other file exists in the same parent directory.
  • Create the HTMLBody with the signature file.
  • Display the message.

Source Code

Copy and paste the code into your Outlook VBA and modify the sites and pages as needed.

Variables to modify:

• Site - Shorthand for site name
• sRootFolder - Root folders that I am interested in
• sURL - Site URL
• iStartSlash - Site URL node to start parsing from. Different sites have different path depths.
• objMsg template - Email template
• Signature - MS Outlook signature file

' In Microsoft Visual Basic for Applications, 
' under Tools | References, enable Microsoft VBScript Regular Expressions 5.5.

' Limitations: An error may appear stating that "Your server administrator has 
' limited the number of items you can open simultaneously.".
'              This limits searching Outlook folders to 250 emails.

Sub GetVoiceMessages()
    ' Set reference to VB Script library.
    ' Microsoft VBScript Regular Expressions 5.5

    Dim Selection As Selection
    Dim olMail As Outlook.MailItem
    Dim obj As Object
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match

    Set Selection = Application.ActiveExplorer.Selection

    For Each obj In Selection
        Set olMail = obj
        Set Reg1 = New RegExp

        For i = 1 To 3
            ' \s* = invisible spaces
            ' \d* = match digits
            ' \w* = match alphanumeric

            With Reg1
                Select Case i
                    Case 1
                        .Pattern = "You received a voice message from (\d+)"
                        .Global = True
                    Case 2
                        .Pattern = "You received a voice message from [\w, ]+ at (\d+)"
                        .Global = True
                    Case 3
                        .Pattern = "You missed a call from (.*)"
                        .Global = True
                End Select
            End With

            If Reg1.Test(olMail.Body) Then
                Set M1 = Reg1.Execute(olMail.Body)
                For Each M In M1
                    Debug.Print olMail.SentOn & ";" & M
                Next
            End If
        Next i
    Next
End Sub

Sub GetSubjects()
    ' Set reference to VB Script library.
    ' Microsoft VBScript Regular Expressions 5.5

    Dim Selection As Selection
    Dim olMail As Outlook.MailItem
    Dim obj As Object
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim strRecipients As String

    Set Selection = Application.ActiveExplorer.Selection

    For Each obj In Selection
        Set olMail = obj
        strRecipients = ""
        
        For i = 1 To olMail.Recipients.Count
            strRecipients = strRecipients & olMail.Recipients(i) & ","
        Next i
        
        strRecipients = Left(strRecipients, Len(strRecipients) - 1)

        Debug.Print olMail.SentOn & ";" & olMail.Sender & ";" & _
                    olMail.Subject & ";" & strRecipients
    Next
End Sub

Sub GetHistoricalPNBs()
    ' Set reference to VB Script library.
    ' Microsoft VBScript Regular Expressions 5.5

    Dim Selection As Selection
    Dim olMail As Outlook.MailItem
    'Dim obj As Object
    Dim Reg1 As RegExp
    Dim Reg2 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim iFile As Integer
    Dim sFile As String
    Dim LastDate As Date
    Dim sLastSubject As String
    Dim objViews As Outlook.Views
    Dim objPreviousView As Outlook.View
    Dim objView As Outlook.View
    Dim i As Long

    ' Applies view to select folder.
    Set objViews = Application.ActiveExplorer.CurrentFolder.Views

    ' Get the view.
    Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
    Set objView = objViews.Item("Date")

    ' Apply the view.
    'objView.Apply

    LastDate = vbNull
    sLastSubject = ""

    ' Set this to wherever you want the output to be saved.
    sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_PNBs.txt"
    iFile = FreeFile
    Open sFile For Output As #iFile

    Set Selection = Application.ActiveExplorer.Selection

    If Selection.Count = 0 Then
        'Application.ActiveExplorer.SelectAllItems
        'Selection = Application.ActiveExplorer.Selection
    End If

    For i = 1 To Selection.Count ' Do reverse for older emails.
        DoEvents
        Set olMail = Selection.Item(i)
        Set Reg1 = New RegExp

        ' \d*  = match digits
        ' \n   = new lines
        ' \r   = carriage return
        ' \s*  = invisible spaces
        ' \w*  = match alphanumeric
        ' \xa0 = non-breaking space

        With Reg1
            .Pattern = "PNB[\s|\xa0]+(\d+-\d+-\d+-\d+[a-zA-Z]*)[\s|\xa0]+(.*)[\r|\n]+\((.*)\)"
            .Global = True
        End With

        If Reg1.Test(olMail.Body) Then
            Set M1 = Reg1.Execute(olMail.Body)
            For Each M In M1
                Set Reg2 = New RegExp
                ' Set Case Insensitivity.
                Reg2.IgnoreCase = True

                With Reg2
                    .Pattern = "historical"
                    .Global = True
                End With

                If Reg2.Test(M.SubMatches(2)) Then
                    If LastDate <> olMail.SentOn Or sLastSubject <> olMail.Subject Then
                        LastDate = olMail.SentOn
                        sLastSubject = olMail.Subject
                        Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
                                             vbTab & olMail.Subject
                    End If

                    Print #iFile, vbTab & "PNB " & M.SubMatches(0) & _
                    vbTab & M.SubMatches(1) & vbCr & vbLf & vbTab & vbTab & M.SubMatches(2)
                End If
            Next
        End If
        Set Reg1 = Nothing
        Set olMail = Nothing
    Next

    Set Selection = Nothing

    MsgBox "Task complete!"

    ' Restore the previous view.
    objPreviousView.Apply

    Close #iFile
End Sub

Sub GetPNBsPerRelease()
    ' Set reference to VB Script library.
    ' Microsoft VBScript Regular Expressions 5.5

    Dim Selection As Selection
    Dim olMail As Outlook.MailItem
    'Dim obj As Object
    Dim Reg1 As RegExp
    Dim Reg2 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim iFile As Integer
    Dim sFile As String
    Dim LastDate As Date
    Dim sLastSubject As String
    Dim objViews As Outlook.Views
    Dim objPreviousView As Outlook.View
    Dim objView As Outlook.View
    Dim i As Long

    ' Applies view to select folder.
    Set objViews = Application.ActiveExplorer.CurrentFolder.Views

    ' Get the view.
    Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
    Set objView = objViews.Item("Date")

    ' Apply the view.
    'objView.Apply

    LastDate = vbNull
    sLastSubject = ""

    ' Set this to wherever you want the output to be saved.
    sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_PNBs.txt"
    iFile = FreeFile
    Open sFile For Output As #iFile

    Set Selection = Application.ActiveExplorer.Selection

    If Selection.Count = 0 Then
        'Application.ActiveExplorer.SelectAllItems
        'Selection = Application.ActiveExplorer.Selection
    End If

    For i = 1 To Selection.Count ' Do reverse for older emails.
        DoEvents
        Set olMail = Selection.Item(i)
        Set Reg1 = New RegExp

        ' \d*  = match digits
        ' \n   = new lines
        ' \r   = carriage return
        ' \s*  = invisible spaces
        ' \w*  = match alphanumeric
        ' \xa0 = non-breaking space

        With Reg1
            .Pattern = "PNB[\s|\xa0]+(\d+-\d+-\d+-\d+[a-zA-Z]*)[\s|\xa0]+(.*)[\r|\n]+\((.*)\)"
            .Global = True
        End With

        If Reg1.Test(olMail.Body) Then
            Set M1 = Reg1.Execute(olMail.Body)
            For Each M In M1
                Set Reg2 = New RegExp
                ' Set Case Insensitivity.
                Reg2.IgnoreCase = True

                With Reg2
                    .Pattern = "Release 5"
                    .Global = True
                End With

                If Reg2.Test(M.SubMatches(2)) Then
                    If LastDate <> olMail.SentOn Or sLastSubject <> olMail.Subject Then
                        LastDate = olMail.SentOn
                        sLastSubject = olMail.Subject
                        Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
                                                             vbTab & olMail.Subject
                    End If

                    Print #iFile, vbTab & "PNB " & M.SubMatches(0) & _
                    vbTab & M.SubMatches(1) & vbCr & vbLf & vbTab & vbTab & M.SubMatches(2)
                End If
            Next
        End If
        Set Reg1 = Nothing
        Set olMail = Nothing
    Next

    Set Selection = Nothing

    MsgBox "Task complete!"

    ' Restore the previous view.
    objPreviousView.Apply

    Close #iFile
End Sub

Sub GetPNBs()
    ' Set reference to VB Script library.
    ' Microsoft VBScript Regular Expressions 5.5

    Dim Selection As Selection
    Dim olMail As Outlook.MailItem
    Dim obj As Object
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim iFile As Integer
    Dim sFile As String
    Dim LastDate As Date
    Dim sLastSubject As String
    Dim objViews As Outlook.Views
    Dim objPreviousView As Outlook.View
    Dim objView As Outlook.View

    ' Applies view to select folder.
    Set objViews = Application.ActiveExplorer.CurrentFolder.Views

    ' Get the view.
    Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
    Set objView = objViews.Item("Date")

    ' Apply the view.
    'objView.Apply

    LastDate = vbNull
    sLastSubject = ""

    ' Set this to wherever you want the output to be saved.
    sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_PNBs.txt"
    iFile = FreeFile
    Open sFile For Output As #iFile

    Set Selection = Application.ActiveExplorer.Selection

    If Selection.Count = 0 Then
        'Application.ActiveExplorer.SelectAllItems
        'Selection = Application.ActiveExplorer.Selection
    End If

    For Each obj In Selection
        Set olMail = obj
        Set Reg1 = New RegExp

        ' \d*  = match digits
        ' \n   = new lines
        ' \r   = carriage return
        ' \s*  = invisible spaces
        ' \w*  = match alphanumeric
        ' \xa0 = non-breaking space

        With Reg1
            .Pattern = "PNB\s*(\d+-\d+-\d+-\d+[a-zA-Z]*)[\s\xa0]+(.*)[\r|\n]+\((.*)\)"
            .Global = True
        End With

        If Reg1.Test(olMail.Body) Then
            Set M1 = Reg1.Execute(olMail.Body)
            For Each M In M1
                If LastDate <> olMail.SentOn Or sLastSubject <> olMail.Subject Then
                    LastDate = olMail.SentOn
                    sLastSubject = olMail.Subject
                    Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
                                  vbTab & olMail.Subject
                End If
                Print #iFile, vbTab & "PNB " & M.SubMatches(0) & _
                vbTab & M.SubMatches(1) & vbCr & vbLf & vbTab & vbTab & M.SubMatches(2)
            Next
        End If
    Next

    ' Restore the previous view.
    objPreviousView.Apply

    Close #iFile
End Sub

Sub GetCDRLs()
    ' Set reference to VB Script library.
    ' Microsoft VBScript Regular Expressions 5.5

    Dim Selection As Selection
    Dim olMail As Outlook.MailItem
    Dim obj As Object
    Dim Reg1 As RegExp
    Dim M1 As MatchCollection
    Dim M As Match
    Dim iFile As Integer
    Dim sFile As String

    ' Set this to wherever you want the output to be saved.
    sFile = "C:\Users\Bassam CTR AbdulBaki\Desktop\WAAS_CDRLs.txt"
    iFile = FreeFile
    Open sFile For Output As #iFile

    Set Selection = Application.ActiveExplorer.Selection

    For Each obj In Selection
        Set olMail = obj
        Set Reg1 = New RegExp

        ' \s* = invisible spaces
        ' \d* = match digits
        ' \w* = match alphanumeric

        With Reg1
            .Pattern = "(.*)CDRL A(\d+-\d+[a-zA-Z]?)([ ,]*)(.*)"
            .Global = True
        End With

        If Reg1.Test(olMail.Subject) Then
            Set M1 = Reg1.Execute(olMail.Subject)
            For Each M In M1
                Print #iFile, Format(olMail.SentOn, "YYYY-MM-DD hh:mm:ss") & _
                                     vbTab & olMail.Subject
                Print #iFile, vbTab & "CDRL A" & M.SubMatches(1) & vbTab & M.SubMatches(3)
            Next
        End If
    Next

    Close #iFile
End Sub

' Read file. Used to enter signature in an email.
Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function

' In Microsoft Visual Basic for Applications, 
' under Tools | References, enable Microsoft Word 16.0 Object Library.
' The general format for DCE links is http://sp1.ecs.raytheon.com/type4/waasdfo/<sRootFolder>/.

Sub GetDCELinks()
    GetURLLinks ("DCE")
End Sub

' In Microsoft Visual Basic for Applications, 
' under Tools | References, enable Microsoft Word 16.0 Object Library.
' The general format for KSN links is https://ksn2.faa.gov/ajw/ajw-1/ajw14B/<sRootFolder>/.

Sub GetKSNLinks()
    GetURLLinks ("KSN")
End Sub

' In Microsoft Visual Basic for Applications, 
' under Tools | References, enable Microsoft Word 16.0 Object Library.

Function GetURLLinks(Site As String)
    On Error GoTo Error_Handler

    Dim Selection As Selection
    Dim objMsg As MailItem
    Dim objMailDocument As Document
    Dim objHyperlink As Hyperlink
    Dim obj As Object
    Dim sMsg As String
    Dim sHyperlinksList() As String
    Dim countHyperlinks As Integer
    Dim i As Integer
    Dim iTemp As Integer
    Dim j As Integer
    Dim k As Integer
    Dim iFailedMsg As Integer
    Dim iTotalMsgs As Integer
    Dim sLink As String
    Dim sRootFolder() ' This array is used as a placeholder on where to start displaying. 
    ' The iStartSlash kind of makes this unnecessary, but I may need it for other subsites.
    Dim bValidPath As Boolean
    Dim bHyperlinkExists As Boolean
    Dim iStartSlash As Integer
    Dim sURL As String

    If Site = "DCE" Then
        sRootFolder = Array("DFO", "CTRCTS", "DELIV", "GSLCTRCTS", "GSLDELIV")
        sURL = "sp1.ecs.raytheon.com"
        iStartSlash = 5
    ElseIf Site = "KSN" Then
        sRootFolder = Array("")
        sURL = "ksn2.faa.gov"
        iStartSlash = 6
    Else
        Exit Function
    End If

'    sRootFolder = Array("")

    ' Create email message.
    Set Selection = Application.ActiveExplorer.Selection
    Set objMsg = Application.CreateItem(olMailItem)
    iTotalMsgs = Selection.Count
    sMsg = "<HTML><BODY><B>" & Site & "</B><BR/>"

    With objMsg
        .To = "Shapiro, Vadim CTR (FAA) <Vadim.CTR.Shapiro@faa.gov>; Edora, _
         Emile CTR (FAA) <Emile.CTR.Edora@faa.gov>; Mills, Charlene CTR (FAA) _
         <Charlene.CTR.Mills@faa.gov>; Farouki, Ibrahim (FAA) <ibrahim.farouki@faa.gov>; _
         Cappelano, Peter CTR (FAA) <Peter.CTR.Cappelano@faa.gov>; Hunt, _
         Charles R-CTR (FAA) <Charles.R-CTR.Hunt@faa.gov>"
        .CC = "Ditchfield, Lori CTR (FAA) <Lori.CTR.Ditchfield@faa.gov>; Zhao, _
         Peng CTR (FAA) <peng.ctr.zhao@faa.gov>; Govan, _
         Vernon CTR (FAA) <Vernon.CTR.Govan@faa.gov>"
        .Subject = "Latest WAAS Documents"
        .BodyFormat = olFormatHTML
        '.HTMLBody = "<HTML><BODY></BODY></HTML>"
        '.Attachments.Add ("path-to-file.docx")

        i = 0
        iFailedMsg = 0

        ' Get all hyperlinks from all emails.
        For Each obj In Selection
            iFailedMsg = iFailedMsg + 1
            Set objMailDocument = obj.GetInspector.WordEditor
            countHyperlinks = objMailDocument.Hyperlinks.Count

            If (countHyperlinks > 0) Then
                For Each objHyperlink In objMailDocument.Hyperlinks
                    sLink = objHyperlink.Address
                    ' Only add hyperlinks that contain the URL.
                    If InStr(sLink, sURL) > 0 Then
                        bValidPath = True
                        Dim sPath As String
                        sPath = UCase(Right(sLink, Len(sLink) - InStrRev(sLink, "/")))
                        For k = LBound(sRootFolder) To UBound(sRootFolder)
                            If sPath = sRootFolder(k) Then
                                bValidPath = False
                                Exit For
                            End If
                        Next k
                        ' Only add hyperlinks that begin with "View ".
                        If bValidPath And (InStr(objHyperlink.TextToDisplay, "View ") > 0) Then
                            ' Do not add if this hyperlink was previously added 
                            ' or it is a directory path that exists.
                            ' The directory path check will fail 
                            ' if it is added before any other file with the same path
                            '   since it is the first time being added.  TODO: Fix this.
                            If (Len(Join(sHyperlinksList)) > 0) Then
                                bHyperlinkExists = False
                                For j = LBound(sHyperlinksList) To UBound(sHyperlinksList)
                                    If (UCase(sLink) = UCase(sHyperlinksList(j))) _
                                        Or (UCase(sLink) = Left(UCase(sHyperlinksList(j)), _
                                        Len(sLink))) Then
                                        bHyperlinkExists = True
                                        Exit For
                                    End If
                                Next j
                            End If
                            If bHyperlinkExists = False Then
                                ReDim Preserve sHyperlinksList(i)
                                sHyperlinksList(i) = objHyperlink.Address
                                i = i + 1
                            End If
                        End If
                    End If
                Next

                ' Sort the hyperlinks alphabetically (case-insensitive).
                If (Len(Join(sHyperlinksList)) > 0) Then
                    Dim First As Integer, Last As Long
                    Dim i2 As Long, j2 As Long
                    Dim Temp As String
                    Dim str1 As String, str2 As String
                    First = LBound(sHyperlinksList)
                    Last = UBound(sHyperlinksList)
                    If (First < Last) Then
                        For i2 = First To Last - 1
                            For j2 = i2 + 1 To Last
                                str1 = sHyperlinksList(i2)
                                str2 = sHyperlinksList(j2)
                                If (UCase(str1) > UCase(str2)) Then
                                    Temp = sHyperlinksList(j2)
                                    sHyperlinksList(j2) = sHyperlinksList(i2)
                                    sHyperlinksList(i2) = Temp
                                ElseIf (UCase(str1) = UCase(Left(str2, Len(str1)))) Then
                                    sHyperlinksList(i2) = "" ' Attempting to fix the 
                                                             ' duplicate path directory. 
                                                 ' The dangling path issue still remains.
                                ElseIf (UCase(str2) = UCase(Left(str1, Len(str2)))) Then
                                    sHyperlinksList(j2) = "" ' Attempting to fix 
                                                             ' the duplicate path directory.
                                                 ' The dangling path issue still remains.
                                End If
                            Next j2
                        Next i2
                    End If
                End If
            End If

            Set objMailDocument = Nothing
            Set obj = Nothing
        Next obj

        ' Display linked files in structures.
        If (Len(Join(sHyperlinksList)) > 0) Then
            Dim sDirectoryPath() As String
            Dim sPrevDirPath() As String
            Dim sNextDirPath() As String
            Dim sParentLevel() As String
            Dim iOwnLevel() As Integer
            Dim bStructurePath As Boolean
            Dim iLargestPath, iPreviousLength As Integer
            iLargestPath = 0

            ' ReDim all directory paths to the deepest directory path.
            For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
                If (sHyperlinksList(i) <> "") Then ' Needed since duplicate paths 
                                                   ' were blanked during sort above.
                    sDirectoryPath = Split(sHyperlinksList(i), "/")
                    iPreviousLength = UBound(sDirectoryPath) - LBound(sDirectoryPath)
    
                    If iLargestPath < iPreviousLength Then
                        iLargestPath = iPreviousLength
                    End If
                End If
            Next i

            ' Save the (string) parent level and (integer) own level separately.
            ' This allows own level to be incremented easily.
            ReDim sParentLevel(UBound(sHyperlinksList) - LBound(sHyperlinksList), iLargestPath)
            ReDim iOwnLevel(UBound(sHyperlinksList) - LBound(sHyperlinksList), iLargestPath)

            For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
                If (sHyperlinksList(i) <> "") Then
                    sDirectoryPath = Split(sHyperlinksList(i), "/")
                    sPrevDirPath = sDirectoryPath
                    Exit For
                End If
            Next i
            
            For j = iStartSlash To UBound(sDirectoryPath)
                ' The first own element is set to one for all levels.
                iOwnLevel(LBound(sHyperlinksList), j) = 1
                For k = iStartSlash To j - 1
                    If (sParentLevel(LBound(sHyperlinksList), j) <> "") Then
                        sParentLevel(LBound(sHyperlinksList), j) = _
                                sParentLevel(LBound(sHyperlinksList), j) & "."
                    End If
                    ' The first parent element is set to one for all levels.
                    sParentLevel(LBound(sHyperlinksList), j) = _
                          sParentLevel(LBound(sHyperlinksList), j) & _
                          iOwnLevel(LBound(sHyperlinksList), k)
                Next k
            Next j

            Erase sDirectoryPath

            For i = LBound(sHyperlinksList) + 1 To UBound(sHyperlinksList)
                If (sHyperlinksList(i) <> "") Then
                    sDirectoryPath = Split(sHyperlinksList(i), "/")
                    For j = iStartSlash To UBound(sDirectoryPath)
                        ' Check if the current node's parent level 
                        ' (current parent and its level) and the previous node's 
                        ' parent level (previous parent and its level) are the same.
                        If ((sParentLevel(i, j - 1) & "." & iOwnLevel(i, j - 1)) = _
                        (sParentLevel(iTemp, j - 1) & "." & iOwnLevel(iTemp, j - 1))) Then
                            ' If the current node path are the same, 
                            ' set the new own level to the previous one.
                            If (sDirectoryPath(j) = sPrevDirPath(j)) Then
                                iOwnLevel(i, j) = iOwnLevel(iTemp, j)
                            Else ' Increment it by one.
                                iOwnLevel(i, j) = iOwnLevel(iTemp, j) + 1
                            End If
                        Else ' If the previous node is unrelated, reset the new own level to one.
                            iOwnLevel(i, j) = 1
                        End If
                        For k = iStartSlash To j - 1
                            If (sParentLevel(i, j) <> "") Then
                                sParentLevel(i, j) = sParentLevel(i, j) & "."
                            End If
                            ' Append the current node's own level to the parent level.
                            sParentLevel(i, j) = sParentLevel(i, j) & iOwnLevel(i, k)
                        Next k
                    Next j
                    sPrevDirPath = sDirectoryPath
                    iTemp = i
                End If
            Next i

            Erase sDirectoryPath

            ' Condense the directory paths.
            For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
                If (sHyperlinksList(i) <> "") Then
                    sDirectoryPath = Split(sHyperlinksList(i), "/")
                    'ReDim Preserve sDirectoryPath(iLargestPath)

                    ' TODO: Change the hardcoded 5 to a while loop.
                    Dim strTemp As String
                    strTemp = ""
                    For j = iStartSlash To UBound(sDirectoryPath) - 1
                        ' TODO: Since the list is alphabetical, 
                        ' you can start from the last root element.
                        If i = LBound(sHyperlinksList) Then
                            strTemp = strTemp & "<UL><LI>_
                            <B>" & sDirectoryPath(j) & "</B>"
                        Else
                            If ((sParentLevel(i, j) & "." & iOwnLevel(i, j)) _
                            <> (sParentLevel(iTemp, j) & "." & iOwnLevel(iTemp, j))) Then
                                If (iOwnLevel(i, j) = 1) Then
                                    strTemp = strTemp & "<UL>"
                                End If
                                strTemp = strTemp & "<LI><B>" _
                                & sDirectoryPath(j) & "</B>"
                            End If
                        End If
                    Next j

                    If InStr(sHyperlinksList(i), sURL) > 0 Then
                        sLink = sHyperlinksList(i)
                        If (i = LBound(sHyperlinksList)) Then
                            strTemp = strTemp + "<UL>"
                        ElseIf ((i > LBound(sHyperlinksList)) And _
                        (sParentLevel(i, j) <> sParentLevel(iTemp, j))) Then
                            strTemp = strTemp + "<UL>"
                        End If
                        strTemp = strTemp & "<LI><A HREF='" & _
                        sLink & "'>" & Right(sLink, Len(sLink) - InStrRev(sLink, "/")) _
                        & "</A></LI>"
                        If (i = UBound(sHyperlinksList)) Then
                            strTemp = strTemp + "</UL>"
                        ElseIf ((i < UBound(sHyperlinksList)) _
                        And (sParentLevel(i, j) <> sParentLevel(i + 1, j))) Then
                            strTemp = strTemp + "</UL>"
                        End If
                    End If

                    bStructurePath = False
                    ' TODO: Change the hardcoded 5 to a while loop.
                    For j = UBound(sDirectoryPath) - 1 To iStartSlash Step -1
                        ' TODO: Since the list is alphabetical, 
                        ' you can start from the last root element.
                        If sDirectoryPath(j) <> "" Then
                            If i = UBound(sHyperlinksList) Then
                                strTemp = strTemp & "</LI></UL>"
                            Else
                                If (sParentLevel(i, j) <> sParentLevel(i + 1, j)) Then
                                    strTemp = strTemp & "</LI></UL>"
                                ElseIf (iOwnLevel(i, j) <> iOwnLevel(i + 1, j)) Then
                                    strTemp = strTemp & "</LI>"
                                End If
                            End If
                        End If
                    Next j
                    sMsg = sMsg + strTemp
                    iTemp = i
                End If
            Next i

            .HTMLBody = sMsg & "<BR>" & _
            GetBoiler(Environ("AppData") & _
            "\Microsoft\Signatures\Signature (FAA).htm") & "</BODY></HTML>"

            .Display
        End If
    End With

    Set objMsg = Nothing
    Exit Function
Error_Handler:
    Msg = "The following error has occurred:" & vbCrLf & vbCrLf
    If Err.Number <> 0 Then
        Msg = Msg & vbTab & "Error Number:" & vbTab & Str(Err.Number) & vbCrLf & _
                vbTab & "Error Source:" & vbTab & Err.Source & vbCrLf & _
                vbTab & "Error Line: " & vbTab & Erl & vbCrLf & _
                vbTab & "Error Description: " & vbTab & Err.Description & vbCrLf & vbCrLf
    End If
    Msg = Msg & vbTab & "Email #: " _
    & vbTab & vbTab & iFailedMsg & " of " & iTotalMsgs & vbCrLf & _
            vbTab & "Subject: " & vbTab & vbTab & obj.Subject
    MsgBox Msg, vbCritical, "Error", Err.HelpFile, Err.HelpContext

End Function

Points of Interest

• None. VBA coding for (X)HTML is a pain.

History

• 2019-07-09 - Fixed a bug when the first path is empty
• 2019-04-12 - Initial submission