Outlook Macro to Export Mail Item to Excel when Rule is triggered

[vamosj]

I have a rule setup to move emails based on subject line. What I am attempting to do is when this rule is triggered, it also grabs the Body, Sent Date, and Sender and places it into an Excel Spreadsheet. After doing a bit of research I have come up with the following and the issue i'm having is getting the Msg Object set properly so I can pull the data from the email. Anyone able to assist?

(Xpost from ExcelForum.com)

Option Explicit

Sub SendToSAMM()
Dim v As Variant
Dim MSndr, MSdt, MSbdy As String
Dim xlApp, xlSht, Msg As Object
Dim R As Integer
Dim MyMail As MailItem 'Move this to () upon seccess of macro




'============================================================================================
' Checks to see if workbook is open and if not opens it up
'============================================================================================


On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = True  'Remove upon success of macro
    xlApp.Workbooks.Open "R:\S***********\K******\S**** S**** A**** M****.xlsm"
Else
End If


'============================================================================================
' Currently having issues with MyMail not being set.
'============================================================================================


On Error GoTo Handler


'Set Msg = ?????????????


Set xlSht = xlApp.Sheets("Email")
R = xlSht.Range("A:A").Find("").Row


With xlSht
    .cells(R, 2).Value = Msg.SentOn
    .cells(R, 3).Value = Msg.Sender
    .cells(R, 4).Value = Msg.Body
End With


Exit Sub
Handler:
Debug.Print "Error occured: " & Err.Description


End Sub

 

[vamosj]

I didn't think this one would have been too difficult to answer. Not one of the 30 people who viewed has an answer? Time to research and play around with it some more then.

 

[vamosj]

And figured out the issue. Code is posted below for anyone else in the future who may want to do the same thing. The problem I had was sine I was trying to troubleshoot it without it being triggered by a rule there was no MailItem attached to a specific email. When it was triggered I no longer needed to set the "Msg" object as "MyMail" was now linked with the incoming email that triggered the rule.

Option Explicit


Sub SendToSAMM(MyMail As MailItem)
Dim MSndr, MSdt, MSbdy As String
Dim xlApp, xlSht, Msg As Object
Dim R As Integer


'============================================================================================
' Checks to see if workbook is open and if not opens it up
'============================================================================================


On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = True  'Remove if you do not require to see the spreadsheet update with the new emai
    xlApp.Workbooks.Open "C:\YourFolder\YourExtremelyHelpfulSpreadsheet.xlsm"
Else
End If


'============================================================================================
' Grabs Send Date/Time, Sender, & Body of the incoming Email.
'============================================================================================


On Error GoTo Handler


Set xlSht = xlApp.Sheets("Email")
R = xlSht.Range("B:B").Find("").Row 'Finds the first open cell in specified column on the sheet you want to place your data.


With xlSht
    .Cells(R, 2).Value = MyMail.SentOn
    .Cells(R, 3).Value = MyMail.Sender
    .Cells(R, 4).Value = MyMail.Body
    .Range("A:C").EntireColumn.Autofit
    .Row(R).Height = 15
End With


Exit Sub
Handler:
Debug.Print "Error occured: " & Err.Description


End Sub