Disclaimer: This is the most convoluted piece of code that I have written in VBA. However, the task itself is asinine and after going on vacation for two weeks and seeing a few hundred of these SharePoint email notifications, I decided to automate it.
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
Sub GetVoiceMessages()
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
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()
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()
Dim Selection As Selection
Dim olMail As Outlook.MailItem
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
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
Set objView = objViews.Item("Date")
LastDate = vbNull
sLastSubject = ""
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
End If
For i = 1 To Selection.Count
DoEvents
Set olMail = Selection.Item(i)
Set Reg1 = New RegExp
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
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!"
objPreviousView.Apply
Close #iFile
End Sub
Sub GetPNBsPerRelease()
Dim Selection As Selection
Dim olMail As Outlook.MailItem
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
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
Set objView = objViews.Item("Date")
LastDate = vbNull
sLastSubject = ""
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
End If
For i = 1 To Selection.Count
DoEvents
Set olMail = Selection.Item(i)
Set Reg1 = New RegExp
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
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!"
objPreviousView.Apply
Close #iFile
End Sub
Sub GetPNBs()
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
Set objViews = Application.ActiveExplorer.CurrentFolder.Views
Set objPreviousView = Application.ActiveExplorer.CurrentFolder.CurrentView
Set objView = objViews.Item("Date")
LastDate = vbNull
sLastSubject = ""
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
End If
For Each obj In Selection
Set olMail = obj
Set Reg1 = New RegExp
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
objPreviousView.Apply
Close #iFile
End Sub
Sub GetCDRLs()
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
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
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
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
Sub GetDCELinks()
GetURLLinks ("DCE")
End Sub
Sub GetKSNLinks()
GetURLLinks ("KSN")
End Sub
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()
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
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
i = 0
iFailedMsg = 0
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
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
If bValidPath And (InStr(objHyperlink.TextToDisplay, "View ") > 0) Then
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
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) = ""
ElseIf (UCase(str2) = UCase(Left(str1, Len(str2)))) Then
sHyperlinksList(j2) = ""
End If
Next j2
Next i2
End If
End If
End If
Set objMailDocument = Nothing
Set obj = Nothing
Next obj
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
For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
If (sHyperlinksList(i) <> "") Then
sDirectoryPath = Split(sHyperlinksList(i), "/")
iPreviousLength = UBound(sDirectoryPath) - LBound(sDirectoryPath)
If iLargestPath < iPreviousLength Then
iLargestPath = iPreviousLength
End If
End If
Next i
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)
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
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)
If ((sParentLevel(i, j - 1) & "." & iOwnLevel(i, j - 1)) = _
(sParentLevel(iTemp, j - 1) & "." & iOwnLevel(iTemp, j - 1))) Then
If (sDirectoryPath(j) = sPrevDirPath(j)) Then
iOwnLevel(i, j) = iOwnLevel(iTemp, j)
Else
iOwnLevel(i, j) = iOwnLevel(iTemp, j) + 1
End If
Else
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
sParentLevel(i, j) = sParentLevel(i, j) & iOwnLevel(i, k)
Next k
Next j
sPrevDirPath = sDirectoryPath
iTemp = i
End If
Next i
Erase sDirectoryPath
For i = LBound(sHyperlinksList) To UBound(sHyperlinksList)
If (sHyperlinksList(i) <> "") Then
sDirectoryPath = Split(sHyperlinksList(i), "/")
Dim strTemp As String
strTemp = ""
For j = iStartSlash To UBound(sDirectoryPath) - 1
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
For j = UBound(sDirectoryPath) - 1 To iStartSlash Step -1
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