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