Last active
May 10, 2023 23:08
-
-
Save masqueNada/486d052394f33a8e68b1e77cffe8b3ab to your computer and use it in GitHub Desktop.
Outlook Failed Email Extractor
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Sub ExtractFailedEmailAttempts() | |
| On Error Resume Next | |
| Dim myItem As Outlook.ReportItem | |
| Dim olItems As Items | |
| Dim i As Integer | |
| Set myOlApp = Outlook.Application | |
| Set mynamespace = myOlApp.GetNamespace("mapi") | |
| Set myfolder = myOlApp.ActiveExplorer.CurrentFolder | |
| Set xlobj = CreateObject("Excel.Application") | |
| xlobj.Visible = True | |
| xlobj.Workbooks.Add | |
| xlobj.Range("a" & 1).Value = "Type" | |
| xlobj.Range("b" & 1).Value = "Date" | |
| xlobj.Range("c" & 1).Value = "Subject" | |
| xlobj.Range("d" & 1).Value = "Email(s)" | |
| Set olItems = myfolder.Items | |
| i = 1 | |
| For Each olItem In olItems | |
| xlobj.Range("a" & i + 1).Value = TypeName(olItem) | |
| If TypeName(olItem) = "MailItem" Then | |
| xlobj.Range("b" & i + 1).Value = olItem.ReceivedTime | |
| xlobj.Range("c" & i + 1).Value = olItem.Subject | |
| ElseIf TypeName(olItem) = "ReportItem" Then | |
| xlobj.Range("b" & i + 1).Value = olItem.CreationTime | |
| xlobj.Range("c" & i + 1).Value = olItem.Subject | |
| xlobj.Range("d" & i + 1).Value = ExtractEmailAddresses(olItem.body) | |
| ElseIf TypeName(olItem) = "MeetingItem" Then | |
| xlobj.Range("b" & i + 1).Value = olItem.ReceivedTime | |
| xlobj.Range("c" & i + 1).Value = olItem.Subject | |
| End If | |
| i = i + 1 | |
| Next olItem | |
| End Sub | |
| Function ExtractEmailAddresses(body As String) As String | |
| On Error Resume Next | |
| If body Like "* has failed to these recipients *" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "* rejected your message &" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*Your message to * couldn't be delivered*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*Your message couldn't be delivered to multiple recipients*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*Your message wasn't delivered to *" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "* too many recipients*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*Recipient address rejected*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*Your message couldn't be delivered to the recipients shown below*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*A message that you sent could not be delivered*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*The following message to * was undeliverable*" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "* rejected your message *" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| ElseIf body Like "*Failed to deliver to *" Then | |
| ExtractEmailAddresses = ExtractAndConcatenateEmails(body) | |
| Else | |
| ExtractEmailAddresses = body | |
| End If | |
| End Function | |
| Function ExtractAndConcatenateEmails(ByVal body As String) As String | |
| emailsArray = ExtractEmailsFromText(body) | |
| extractedEmails = "" | |
| i = 1 | |
| For Each Email In emailsArray | |
| If Email Like "*outlook*" Then | |
| 'No-op | |
| ElseIf Email Like "*brenntag*" Then | |
| 'No-op | |
| ElseIf extractedEmails Like ("*" & Email & "*") Then | |
| 'No-op | |
| Else | |
| extractedEmails = extractedEmails & Email | |
| If i = UBound(emailsArray) Then | |
| 'No-op | |
| Else | |
| extractedEmails = extractedEmails & " & " | |
| End If | |
| End If | |
| i = i + 1 | |
| Next Email | |
| 'Remove trailing " & " | |
| extractedEmails = Left(extractedEmails, Len(extractedEmails) - 3) | |
| ExtractAndConcatenateEmails = extractedEmails | |
| End Function | |
| Function ExtractEmailsFromText(ByVal sInput As String) As Variant | |
| On Error GoTo Error_Handler | |
| Dim oRegEx As Object | |
| Dim oMatches As Object | |
| Dim oMatch As Object | |
| Dim sEmail As String | |
| If Not IsNull(sInput) Then | |
| Set oRegEx = CreateObject("vbscript.regexp") | |
| With oRegEx | |
| 'Basic pattern | |
| '.Pattern = "([a-zA-Z0-9._-]+@[a-zA-Z0-9._-]+\.[a-zA-Z0-9_-]+)" | |
| 'More advanced pattern that allow accented characters | |
| .Pattern = "([a-zA-ZF0-9\u00C0-\u017F._-]+@[a-zA-Z0-9\u00C0-\u017F._-]+\.[a-zA-Z0-9\u00C0-\u017F_-]+)" | |
| .Global = True | |
| .IgnoreCase = True | |
| .MultiLine = True | |
| Set oMatches = .Execute(sInput) | |
| End With | |
| For Each oMatch In oMatches | |
| sEmail = oMatch.Value & "," & sEmail | |
| Next oMatch | |
| If Right(sEmail, 1) = "," Then sEmail = Left(sEmail, Len(sEmail) - 1) | |
| ExtractEmailsFromText = Split(sEmail, ",") 'Return an array of email addresses extracted from sInput | |
| Else | |
| ExtractEmailsFromText = Null | |
| End If | |
| Error_Handler_Exit: | |
| On Error Resume Next | |
| If Not oMatch Is Nothing Then Set oMatch = Nothing | |
| If Not oMatches Is Nothing Then Set oMatches = Nothing | |
| If Not oRegEx Is Nothing Then Set oRegEx = Nothing | |
| Exit Function | |
| Error_Handler: | |
| MsgBox "The following error has occured" & vbCrLf & vbCrLf & _ | |
| "Error Number: " & Err.Number & vbCrLf & _ | |
| "Error Source: ExtractEmailAddresses" & vbCrLf & _ | |
| "Error Description: " & Err.Description & _ | |
| Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _ | |
| , vbOKOnly + vbCritical, "An Error has Occured!" | |
| Resume Error_Handler_Exit | |
| End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment