Extract outlook email (from, to, cc, subject, mail body) data to excel file

YSWOO

New Member
Joined
Dec 7, 2020
Messages
10
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
  2. Mobile
HI

I want to ask how to copy email from outlook into excel.

My main Goal is to copy the body (as table or htmlbody or text whatever) into excel as being original.

(1) Range("EMAIL_BODY").Offset(i, 0).Value = OutlookMail.Body
-> If I use above it, Email body is copied as text.
-> So, that is one problem.

(2) ' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable

Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With

'import in Excel
For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next
-> if i use above it, Email body is copied as table, but the thing is that all table is copied in case of Email is forward or reply.
-> I want to use only today email date(receipt)

How to figure two-problem and one-request out ?
(1) text -> text / table -> table / diagram -> diagram : as original
(2) only copy in date of today
(3) additionally, i want to fix specific sender


please help me out...
coding until now, below like that ;

Public Sub Import_Tables_From_Outlook_Emails()

Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Dim x As Long, y As Long
Dim destCell As Range
Dim OutlookMail As Variant

With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With

On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If oApp Is Nothing Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0

Set oMapi = oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("MACRO")

'oApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders ("MACRO")

'oApp.GetNamespace("MAPI").PickFolder
If Not oMapi Is Nothing Then

For Each oMail In oMapi.Items

'Get HTML tables from email object

Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oMail.HTMLBody
Set tables = .getElementsByTagName("table")
End With

'Import each table into Excel

For Each table In tables
For x = 0 To table.Rows.Length - 1
For y = 0 To table.Rows(x).Cells.Length - 1
destCell.Offset(x, y).Value = table.Rows(x).Cells(y).innerText
Next y
Next x
Set destCell = destCell.Offset(x)
Next

Next

MsgBox "Finished"

End If

Set oApp = Nothing
Set oMapi = Nothing
Set oMail = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing

End Sub
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

Forum statistics

Threads
1,223,888
Messages
6,175,213
Members
452,618
Latest member
Tam84

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top