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

[YSWOO]

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.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.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