How to export e-mail in excel worksheet

[ThrottleWorks]

Hi,

I am trying to export an e-mail to excel worksheet.
But am not able to do so. I want to export e-mail with its original format to excel.

E-mail contains few text lines and a table, I need to export it to excel as it is for further processing.

I want to copy e-mail and paste in excel. But I do not know how to use 'e-mail copy' in VBA.

The code I am using is not helpful for this. Can anyone please help me in this.

Sub ExportEmailToExcel()
    Dim MyItem As Outlook.MailItem
    Dim myAttachments As Outlook.Attachments
    Dim objApp As Object
    Dim i As Long
    Dim Att As String
    Dim sFile As Variant
    Dim myOutput As Variant
    Dim Filename As Variant
    Dim RawBook As Variant
    Dim RawSht As Variant
    Dim myShell As Variant
  
    Set objApp = Outlook.Application
  
    On Error Resume Next
        Select Case TypeName(objApp.ActiveWindow)
            Case "Explorer"
                Set MyItem = ActiveExplorer.Selection.Item(1)
            Case "Inspector"
                Set MyItem = ActiveInspector.CurrentItem
            Case Else
        End Select
    On Error GoTo 0
  
    Dim EmailDump As Worksheet
    Set EmailDump = ThisWorkbook.Worksheets("EmailDump")
  
    EmailDump.Range("A1") = MyItem.Body
  
    Set myAttachments = Nothing
    Set MyItem = Nothing
    Set myShell = Nothing
End Sub

 

[Chihiro]

First of all, do you have reference to Outlook in the project?

If not, variables declared with Outlook.xxx will give error.

Otherwise, code should work as is to bring in email body to Excel sheet.

 

[ThrottleWorks]

Hi @Chihiro sir, thanks a lot for the help.
I have included reference.

However, the code which I am using puts entire e-mail content in cell A1.
I want to get the e-mail body as it is.

For example,
e-mail line 1 = Hi,
e-mail line 2 = blank
e-mail line 3 = Yamaha
e-mail line 4 = blank
from e-mail line 5, table.

Current code puts everything mentioned above in cell A1.

I want to paste e-mail as it is.
Could you please help if you get time.

 

[ThrottleWorks]

Hi,

Please find attached file for more details.

Sheet1 is the result of current code.
I need output as mentioned in Sheet2 J1.

Screenshot is given for reference purpose.

 

[Chihiro]

Hmm, to export table you'd need to use ".HTMLBODY" instead of ".BODY".

You will then need to parse HTML into Excel format.

I just got busy at work. I probably won't have time to work on code today. I'll see if I can find time to play with it tomorrow.

 

[ThrottleWorks]

Hi,

Please find attached file for your reference.
In cell G1 I have pasted screen shot of how a dummy e-mail will look.

Please note, tables in e-mail are not normal excel based table, I guess these are html type of tables.

I want macro output in excel as seen in cell A1.
Please help if you get time.

 

[ThrottleWorks]

Hi @Chihiro sir, just read your reply, yes, you are right, thanks a lot for the help.

Please take your own time, help only if you get time.

Have a nice day ahead.

 

[Chihiro]

Had a bit of time and had a thought. Instead of parsing god awful Outlook.HTMLBody to Excel Range... why not write .HTMLBody to local file (.txt) and then import?

It won't retain formatting, but it will be much faster than parsing .HTMLBody.
You don't need to delete the file and just keep on reusing.

Sub ExportEmailToExcel()
    Dim MyItem As Outlook.MailItem
    Dim myAttachments As Outlook.Attachments
    Dim objApp As Object
    Dim i As Long
    Dim Att As String
    Dim sFile As Variant
    Dim myOutput As Variant
    Dim Filename As Variant
    Dim RawBook As Variant
    Dim RawSht As Variant
    Dim myShell As Variant
 
    Set objApp = Outlook.Application
 
    On Error Resume Next
        Select Case TypeName(objApp.ActiveWindow)
            Case "Explorer"
                Set MyItem = ActiveExplorer.Selection.Item(1)
            Case "Inspector"
                Set MyItem = ActiveInspector.CurrentItem
            Case Else
        End Select
    On Error GoTo 0
 
    Dim EmailDump As Worksheet
    Set EmailDump = ThisWorkbook.Worksheets("Sheet2")
 
'    EmailDump.Range("A1") = MyItem.HTMLBody
   
    Dim oPath As String: oPath = "C:\Test\EmailHTML.txt" 'Change path
    Dim intFF As Integer: intFF = FreeFile()
   
    Open oPath For Output As #intFF
    Print #intFF, MyItem.HTMLBody
    Close #intFF
   
    Call ImportHTML(oPath, EmailDump.Range("A1"))
   
    Set myAttachments = Nothing
    Set MyItem = Nothing
    Set myShell = Nothing
End Sub

Sub ImportHTML(hPath As String, oRange As Range)
    With oRange.Parent.QueryTables.Add(Connection:= _
        "URL;file:///" & hPath, Destination:=oRange)
        .Name = "EmailHTML_1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    For Each cn In ThisWorkbook.Connections
        cn.Delete
    Next
End Sub

 

[ThrottleWorks]

Hi @Chihiro sir , you are great ! And this too looks subdued looking at your code.

Thanks a lot. Have a nice day ahead.