VBA to Copy Email Body and Paste to New Workbook

[jardenp]

I'm not sure if this should be in this forum or the "Other Applications" forum since it's in an Outlook module. Please let me know if it needs moved.

I want to have a macro in Outlook that will copy the body of the currently selected email to a new Excel workbook. It would be great if it could then run a macro stored in an Excel module on the new workbook but I can work around that if it's not possible.

The manual process is:
1. In Outlook, click on the email body and Ctrl+a to select everything, then Ctrl+c to copy
2. Go to Excel and Ctrl+n to create a new workbook
3. Click on A1 in the new workbook and Ctrl+v to paste
4. Run an existing macro on the new workbook (Sub EmailExportToRecord() stored in the PERSONAL.xlsm file)

This pastes the body on rows 1 to ~30. I have the code below (cobbled from various Internet sources) in an Outlook module that will put the email body in A1 of the new sheet, but it's a single text string. I don't need the original formatting, but I would like to paste in with new rows for each vbCrLf, vbCr, or whatever the character in the string is being used for a new row.

It seems like I'm almost there. I could write a string parser but the string isn't exactly consistent and I know my Excel macro works on the copy/paste. I'm thinking there must be a way to do the equivalent of select all>copy>paste.

Thank you!

Sub EmailBodyToNewExcelWB()
    Dim MyMail As Outlook.MailItem
    Dim objInspector As Outlook.Inspector
    Set MyMail = Outlook.Application.ActiveInspector.CurrentItem
   
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String
   
    '~~> Excel Variables
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object
    Dim lRow As Long
   
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
   
    '~~> Establish an EXCEL application object
    On Error Resume Next
    Set oXLApp = GetObject(, "Excel.Application")
   
    '~~> If not found then create new instance
    If Err.Number <> 0 Then
        Set oXLApp = CreateObject("Excel.Application")
    End If
    Err.Clear
    On Error GoTo 0
   
    '~~> Show Excel
    oXLApp.Visible = True
   
    '~~> Open the relevant file
    Set oXLwb = oXLApp.Workbooks.Add
   
    '~~> Set the relevant output sheet. Change as applicable
    Set oXLws = oXLwb.Sheets("Sheet1")
   
    '~~> Write to excel
    oXLws.Cells(1, 1) = olMail.Body

    Set oXLws = Nothing
    Set oXLwb = Nothing
    Set oXLApp = Nothing
   
    Set olMail = Nothing
    Set olNS = Nothing
End Sub