Extract Body Text From Outlook Email To Excel

[needhelp2]

Hi, I wanna extract email body text from Outlook to excel and I am using my Gmail in outlook and all emails are available in Inbox folder moreover my subject is same in all emails but body text could be different and i got mentioned below code from search but not working. Please help me in this regard.Thankx in Advance.

sub ExtractBodySubjectFromMails()

Dim oNS As Outlook.Namespace
Dim oFld As Outlook.Folder
Dim oMails As Outlook.Items
Dim oMailItem As Outlook.MailItem
Dim oProp As Outlook.PropertyPage

Dim sSubject As String
Dim sBody

On Error GoTo Err_OL

Set oNS = Application.GetNamespace("MAPI")
Set oFld = oNS.GetDefaultFolder(olFolderInbox)
Set oMails = oFld.Items

For Each oMailItem In oMails
sBody = oMailItem.Body
sSubject = oMailItem.Subject 'This property corresponds to the MAPI property PR_SUBJECT. The Subject property is the default property for Outlook items.
Next

Exit Sub
Err_OL:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
Resume Next
End If
End Sub

 

[needhelp2]

Waooooooooow That's Working Perfect, Thank you sooooooooooooooooo much, you are really great.I have no words to say thanks but yes Thank you & God bless you .

 

[Domenic]

I've amended the code so that it counts the number of emails that have been extracted, and then it displays that count in a message box. What happens when you run this one?

Option Explicit

Sub ExtractBodySubjectFromMails()

    Dim oApp            As Object
    Dim oNS             As Object
    Dim oFld            As Object
    Dim oMail           As Variant
    
    Dim sSubject        As String
    Dim sBody           As String
    Dim Cnt             As Long
    Dim Rw              As Long
        
    On Error GoTo ErrHandler
    
    Application.ScreenUpdating = False
    
    Set oApp = CreateObject("Outlook.Application")
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFld = oNS.GetDefaultFolder(6)
    
    Cnt = 0
    Rw = 2
    For Each oMail In oFld.Items
        If TypeName(oMail) = "MailItem" Then
            Cnt = Cnt + 1
            sSubject = oMail.Subject
            sBody = oMail.Body
            Cells(Rw, "A").Value = sSubject
            Cells(Rw, "B").Value = sBody
            Rw = Rw + 1
        End If
    Next oMail
    
    Columns("A:B").WrapText = False
    
    MsgBox Cnt & " emails have been extracted.", vbInformation

FinishUp:
    Application.ScreenUpdating = True
    
    Exit Sub
    
ErrHandler:
    If Err <> 0 Then
        MsgBox Err.Number & " - " & Err.Description
    End If
    
    Resume FinishUp
    
End Sub

 

[needhelp2]

thank you , that's great n sooo nice of you.

 

[Domenic]

That's great, I'm glad it's working for you. As an alternative, you may want to use the last macro I offered, since it tells you the number of emails that was extracted.

Cheers!

 

[needhelp2]

yes definitely, I will use the very last shared macro

 

[George Srebrov]

Hello, This is very helpful code you have provided, it works perfectly! May I ask how to add field "Sent" to be displayed, As I need the time stamps from certain emails and if there is a way to navigate the excel file to extract not all emails from inbox, but from certain sub-folder in the Inbox. I need the body of the email, which works perfectly with the code provided, however I have to calculate the time (therefore I need the time stamps), based on emails send in two different sub-folders Named OPEN and CLOSED. Thank you very much in advance. I am new here, so I was not sure where to write.

 

[snb_]

Sub M_snb() 
  With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6)
     for each it in .Items
        c00 = c00 & vblf & it.To & " " & it.subject & " " & it.body & " " & it.sentOn
    next
  End With

  Msgbox c00
End Sub

For more information see: http://www.snb-vba.eu/VBA_Outlook_external_en.html#H8

 

[George Srebrov]

From what I understand I should place this code in Outlook VBA. I used this code provided earlier:

Option Explicit


Sub ExtractBodySubjectFromMails()


Dim oApp As Object
Dim oNS As Object
Dim oFld As Object
Dim oMail As Variant

Dim sSubject As String
Dim sBody As String
Dim Cnt As Long
Dim Rw As Long

On Error GoTo ErrHandler

Application.ScreenUpdating = False

Set oApp = CreateObject("Outlook.Application")
Set oNS = oApp.GetNamespace("MAPI")
Set oFld = oNS.GetDefaultFolder(6)

Cnt = 0
Rw = 2
For Each oMail In oFld.Items
If TypeName(oMail) = "MailItem" Then
Cnt = Cnt + 1
sSubject = oMail.Subject
sBody = oMail.Body
Cells(Rw, "A").Value = sSubject
Cells(Rw, "B").Value = sBody
Rw = Rw + 1
End If
Next oMail

Columns("A:B").WrapText = False

MsgBox Cnt & " emails have been extracted.", vbInformation


FinishUp:
Application.ScreenUpdating = True

Exit Sub

ErrHandler:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
End If

Resume FinishUp

End Sub


So I need to modify it to show me "Sent" field from Outlook emails with date and hour, and show it on next column in excel and to be able to extract emails from sub folder "OPEN". Then I guess it will be another macro with the same code but extracted on another sheet for sub folder "CLOSE". Once I get the time stamps I know how to calculate the rest. I have tried to change Set oFld = oNS.GetDefaultFolder(6) with Set olFld = olFolder.Folders("OPEN") but it did not work.

 

[Domenic]

Hello, This is very helpful code you have provided, it works perfectly! May I ask how to add field "Sent" to be displayed, As I need the time stamps from certain emails and if there is a way to navigate the excel file to extract not all emails from inbox, but from certain sub-folder in the Inbox. I need the body of the email, which works perfectly with the code provided, however I have to calculate the time (therefore I need the time stamps), based on emails send in two different sub-folders Named OPEN and CLOSED. Thank you very much in advance. I am new here, so I was not sure where to write.

Try...

[COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit
[/COLOR]
[COLOR=darkblue]Sub[/COLOR] ExtractDataFromEmails()

    [COLOR=darkblue]Dim[/COLOR] olApp           [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] olNS            [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] olInbox         [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Object[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] oMail           [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    
    [COLOR=darkblue]Dim[/COLOR] vSubFolders     [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] vSubFolder      [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] sSubject        [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] sBody           [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] sSent           [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] Cnt             [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] Rw              [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]
        
    [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] ErrHandler
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    vSubFolders = Array("Open", "Closed")
    
    [COLOR=darkblue]Set[/COLOR] olApp = CreateObject("Outlook.Application")
    [COLOR=darkblue]Set[/COLOR] olNS = olApp.GetNamespace("MAPI")
    [COLOR=darkblue]Set[/COLOR] olInbox = olNS.GetDefaultFolder(6)
    
    Cnt = 0
    Rw = 2
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vSubFolder [COLOR=darkblue]In[/COLOR] vSubFolders
        [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] oMail [COLOR=darkblue]In[/COLOR] olInbox.Folders(vSubFolder).Items
            [COLOR=darkblue]If[/COLOR] TypeName(oMail) = "MailItem" [COLOR=darkblue]Then[/COLOR]
                Cnt = Cnt + 1
                sSubject = oMail.Subject
                sBody = oMail.Body
                sSent = oMail.SentOn
                Cells(Rw, "A").Value = s[COLOR=darkblue]Sub[/COLOR]ject
                Cells(Rw, "B").Value = sBody
                Cells(Rw, "C").Value = sSent
                Rw = Rw + 1
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        [COLOR=darkblue]Next[/COLOR] oMail
    [COLOR=darkblue]Next[/COLOR] v[COLOR=darkblue]Sub[/COLOR]Folder
    
    Columns("A:C").WrapText = [COLOR=darkblue]False[/COLOR]
    
    MsgBox Cnt & " emails have been extracted.", vbInformation

FinishUp:
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
    [COLOR=darkblue]Exit[/COLOR] Sub
    
ErrHandler:
    [COLOR=darkblue]If[/COLOR] Err <> 0 [COLOR=darkblue]Then[/COLOR]
        MsgBox Err.Number & " - " & Err.Description
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    [COLOR=darkblue]Resume[/COLOR] FinishUp
    
[COLOR=darkblue]End[/COLOR] Sub

Hope this helps!

 

[George Srebrov]

It worked! Thank you very much.