Outlook VBA Copy Paste Email Body From Outlook to Excel

[battery514]

I am having a hard time with this macro, and at this point I feel like I have searched everywhere, and there doesn't seem to be a lot of good Outlook VBA info out there. I have updated the macro to the below code, which correctly opens a new Excel workbook, however, it does not copy the body of the email into said workbook. Obviously, there is an issue with my copy and paste methodology, and I have also tried Send Keys with no avail. Any ideas are greatly appreciated.


Option Explicit

Sub PasteToExcel(item As Outlook.MailItem)
Dim activeMailMessage As MailItem
Dim xlApp As Excel.Application
Dim Wb As Excel.Workbook
Dim Ws As Excel.Worksheet


On Error Resume Next


'Get a handle on the email
Set activeMailMessage = ActiveExplorer.Selection.item(1)


'Copy the formatted text:
activeMailMessage.GetInspector().WordEditor.Range.FormattedText.Copy

'Ensure Excel Application is open
Set xlApp = CreateObject("Excel.Application")


'Make Excel Application visible
xlApp.Visible = True

'Open the Personal Macro Workbook, or the Excel macro won't run
xlApp.Workbooks.Open ("C:\Users\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.xlsb")

'Name the Excel File
Set Wb = xlApp.Workbooks.Add

'Paste the email
Set Ws = xlApp.Sheets(1)
Ws.Activate
Ws.Range("A1").Paste

'Run the Excel macro to clean up the file
xlApp.Run ("PERSONAL.XLSB!Commissions_Report_Format")

End Sub

[gmayor]

The following should work (though obviously I don't know what your supplementary macro does)


Sub PasteToExcel(item As Outlook.MailItem)
Dim olInsp As Inspector
Dim xlApp As Object
Dim Wb As Object
Dim Ws As Object
Dim wdDoc As Object
Dim oRng As Object
Dim fso As Object
Dim strPersonal As String
Dim bStarted As Boolean

strPersonal = Environ("APPDATA") & "\Microsoft\Excel\XLSTART\PERSONAL.xlsb"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(strPersonal) Then
MsgBox "The personal workbook is not at the indicated location"
Exit Sub
End If

'process the message
With item
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
End With

'Ensure Excel Application is open
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
bStarted = True
End If
On Error GoTo 0


'Make Excel Application visible
xlApp.Visible = True

'Open the Personal Macro Workbook, or the Excel macro won't run
If bStarted Then xlApp.Workbooks.Open strPersonal

'Name the Excel File
Set Wb = xlApp.Workbooks.Add

'Paste the email
Set Ws = Wb.Sheets(1)
Ws.Activate
Ws.Range("A1") = oRng.FormattedText

'Run the Excel macro to clean up the file
xlApp.Run ("PERSONAL.XLSB!Commissions_Report_Format")
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Set fso = Nothing
Set xlApp = Nothing
Set Wb = Nothing
Set Ws = Nothing
Exit Sub
End Sub
To test it use
Sub GetMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.item(1)
PasteToExcel olMsg
lbl_Exit:
Exit Sub
End Sub