Hello,
I have an excel spreadsheet with a macro to extract emails from a selected folder which works perfectly when executed from Excel. However, I'd like to build this as a rule in Outlook 2016 to export specific emails when they arrive. I've tried a few things to no avail and was hoping someone could help. The VBA code I have in my Excel sheet is below. I've commented out many of the things I don't need, but may in the future. Right now, i just need to have the sender, subject and body of the email exported into an excel sheet.
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
Sheets("Buyflow").Select
'Find the next empty line of the worksheet
rCount = Range("D" & 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
strBody = Trim(strBody)
strReceived = olItem.ReceivedTime
strSender = olItem.SenderName
'write them in the excel sheet
'Range("A" & rCount) = strReceived ' format using short date
Range("B" & rCount) = strSender
Range("C" & rCount) = olItem.Subject
Range("D" & rCount) = strBody
'Range("E" & rCount) = strReceived 'format using time
'Range("F" & rCount) = strAttCount
'Range("G" & rCount) = olItem.To
'Range("H" & rCount) = olItem.CC
'Range("I" & rCount) = olItem.BCC
'Next row
rCount = rCount + 1
Next
' Basic Formatting
Columns("B:I").Select
With Selection
.WrapText = False
.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").Select
'Selection.ColumnWidth = 20
Range("A2").Select
Sheets("Buyflow Order import").Select
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
I have an excel spreadsheet with a macro to extract emails from a selected folder which works perfectly when executed from Excel. However, I'd like to build this as a rule in Outlook 2016 to export specific emails when they arrive. I've tried a few things to no avail and was hoping someone could help. The VBA code I have in my Excel sheet is below. I've commented out many of the things I don't need, but may in the future. Right now, i just need to have the sender, subject and body of the email exported into an excel sheet.
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
Sheets("Buyflow").Select
'Find the next empty line of the worksheet
rCount = Range("D" & 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
strBody = Trim(strBody)
strReceived = olItem.ReceivedTime
strSender = olItem.SenderName
'write them in the excel sheet
'Range("A" & rCount) = strReceived ' format using short date
Range("B" & rCount) = strSender
Range("C" & rCount) = olItem.Subject
Range("D" & rCount) = strBody
'Range("E" & rCount) = strReceived 'format using time
'Range("F" & rCount) = strAttCount
'Range("G" & rCount) = olItem.To
'Range("H" & rCount) = olItem.CC
'Range("I" & rCount) = olItem.BCC
'Next row
rCount = rCount + 1
Next
' Basic Formatting
Columns("B:I").Select
With Selection
.WrapText = False
.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").Select
'Selection.ColumnWidth = 20
Range("A2").Select
Sheets("Buyflow Order import").Select
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