Context: Every day we get lots of emails containing backup reports and we currently manually count through them and work out what is missing.
I have found a great bit of code (that runs using Visual Basic for Applications) that will pull the emails out of Outlook and put them in Excel.
Now I just need to get rid of the successful ones so it leaves the emails that in the subject line don't have "Result: OK."
Public Sub CopyMailtoExcel()
Dim objOL As Outlook.Application
Dim objFolder As Outlook.Folder
Dim objItems As Outlook.Items
Dim olItem As Object ' MailItem
Dim strDisplayName, strAttCount, strBody, strDeleted As String
Dim strReceived As Date
Dim rCount As Long
' On Error GoTo Err_Execute
Application.ScreenUpdating = False
'Find the next empty line of the worksheet
rCount = Range("A" & Rows.Count).End(-4162).Row
rCount = rCount + 1
Set objOL = Outlook.Application
' copy mail to excel
Set objFolder = objOL.ActiveExplorer.CurrentFolder
Set objItems = objFolder.Items
For Each olItem In objItems
strAttCount = ""
strBody = ""
If olItem.Attachments.Count > 0 Then strAttCount = "Yes"
'On Error Resume Next
'collect the fields
strBody = olItem.Body
' Remove this block if you don't want to remove the hyperlinked urls
Dim Reg1 As RegExp
Dim Match, Matches
Set Reg1 = New RegExp
' remove hyperlinks from bodies for easier reading.
With Reg1
.Pattern = "<[src|http|mailto](.*)>(\s)*"
.Global = True
.IgnoreCase = True
.MultiLine = True
End With
If Reg1.Test(strBody) Then
strBody = Reg1.Replace(strBody, "")
End If
' end remove hyperlinks block
strBody = Trim(strBody)
strReceived = olItem.ReceivedTime
strSender = olItem.SenderName
' column / field
' A Date
' B Time
' C Attachments (Yes)
' D Subject
' E Body
' F From (display name)
' G To (display name)
' H CC (display name)
' I BCC (sent items only)
'write them in the excel sheet
Range("A" & rCount) = strReceived ' format using short date
Range("B" & rCount) = strReceived 'format using time
Range("C" & rCount) = strAttCount
Range("D" & rCount) = olItem.Subject
Range("E" & rCount) = strBody
Range("F" & rCount) = strSender
Range("G" & rCount) = olItem.To
Range("H" & rCount) = olItem.CC
Range("I" & rCount) = olItem.BCC
'Next row
rCount = rCount + 1
Next
' Basic Formatting
Columns("A:I").Select
With Selection
.WrapText = True
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlTop
.Columns.AutoFit
End With
Columns("E:E").Select ' body column
With Selection
.ColumnWidth = 150
.Rows.AutoFit
End With
Range("A1:I1").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.RowHeight = 55
End With
' Date and Time
Columns("A:A").Select
Selection.NumberFormat = "[$-409]ddd mm/dd/yy;@"
Range("B:B").Select
Selection.NumberFormat = "[$-F400]h:mm AM/PM"
Range("D:D").Select
Selection.ColumnWidth = 20
Range("A2").Select
Application.ScreenUpdating = True
Set olItem = Nothing
Set objFolder = Nothing
Set objOL = Nothing
Set Reg1 = Nothing
MsgBox "Email import complete"
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
Below is an example of a successful and a non working backup report email subject line. The profile name is different for each job so that will change. Success:
ViceVersa Notification. Profile: R4Data_D - Result: OK.
Failure
ViceVersa Notification. Profile: ST29 Data - Result: Source folder not found.
The failed ones won't always be as above as they fail for different reasons so I was thinking that I need an IF or IF NOT Statement of some sort that does something like this:
IF the subject line contains anything other than "Result: OK." then don't export
But I know it would need to allow for different Profile names etc.
The other option is to read out of the body of the email and in that case I would want the macro to only extract emails that don't have "Exit Code: 0" in the body of the email.
Sorry I have no idea about how to construct this!
Credit to original Original Code Diane Poremsky
