Help on VBA Code to copy mail body to excel spreadsheet

Y

ykamble

New member
Joined
Jan 28, 2015
Messages
7
Reaction score
0
Points
0
Hello All,

I am looking for help for the below VBA code which I am trying to put Excel to copy & paste the body of the selected mails from outlook to excel spreadsheet. I am getting an error message at line no. 27 as "Application Defined or Object Defined error". I want to VB code to copy body of the message in different rows, but what does the below code is doing is putting the entire body of the message in one single cell. This caused me an error of limitation of data type. Your valuable assistance will be great help for me on this. Thanks in advance.




  1. Sub Mailbody_To_Excel()
  2. Dim ns As Namespace
  3. Dim Inbox As MAPIFolder
  4. Dim myitem As Outlook.MailItem
  5. Dim FileName As String
  6. Dim i As Integer
  7. Dim objSearchFolder As Outlook.MAPIFolder
  8. Dim item As Object
  9. Dim mail As MailItem
  10. Dim vbody As String
  11. Set ns = GetNamespace("MAPI")
  12. Set Inbox = ns.GetDefaultFolder(olFolderInbox)
  13. Set objSearchFolder = Inbox
  14. i = 0
  15. If Inbox.Items.Count = 0 Then
  16. MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
  17. End If
  18. For Each item In Inbox.Items
  19. If item Like "*SubjectLineofmail*" Then
  20. vbody = item.Body
  21. Dim xlApp As Object ' Excel.Application
  22. Dim xlWkb As Object ' Excel.Workbook
  23. Set xlApp = CreateObject("Excel.Application") ' New Excel.Application
  24. xlApp.Visible = True
  25. Set xlWkb = xlApp.Workbooks.Add
  26. xlApp.Range("B4").Value = vbody
  27. xlApp.ActiveWorkbook.SaveAs ("C:\Desktop\DailyReport_" & Format(Date, "MM-DD-YYYY") & ".xls")
  28. xlWkb.Close
  29. xlApp.Quit
  30. Set xlWkb = Nothing
  31. Set xlApp = Nothing
  32. End If
  33. Next
  34. Set objSearchFolder = Nothing
  35. Set Inbox = Nothing
  36. Set ns = Nothing
  37. End Sub
 
If there's more than one email which fulfils item Like "*SubjectLineofmail*" then you're going to be trying to save another workbook with the same name as an existing one which will cause an error. Some re-arrangement is necessary only to create a new instance of Excel and a new workbook if at least one email fulfils the search criterion,and then not to close and save it until all emails have been searched. Also the destination cell of the email body has to be moved down one cell each time an email is found.
Anyway, the following should get you started:
Code: 
Sub Mailbody_To_Excel()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim myitem As Outlook.MailItem
Dim FileName As String
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim item As Object
Dim mail As MailItem
Dim vbody As String
Dim xlApp As Object  ' Excel.Application
Dim xlWkb As Object  ' Excel.Workbook

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
i = 0
If Inbox.Items.Count = 0 Then
  MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
End If
For Each item In Inbox.Items
  If item Like "*SubjectLineofmail*" Then
    If xlApp Is Nothing Then
      Set xlApp = CreateObject("Excel.Application")  ' New Excel.Application
      xlApp.Visible = True
      Set xlWkb = xlApp.Workbooks.Add
      Set DestnCell = xlApp.Range("B4")
    End If
    vbody = item.Body
    DestnCell.Value = vbody
    Set DestnCell = DestnCell.Offset(1)
  End If
Next
If Not xlApp Is Nothing Then
  xlApp.ActiveWorkbook.SaveAs ("C:\Desktop\DailyReport_" & Format(Date, "MM-DD-YYYY") & ".xls")
  xlWkb.Close
  xlApp.Quit
  Set xlWkb = Nothing
  Set xlApp = Nothing
End If
Set objSearchFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
End Sub
 
Hello p45cal,

Thanks for your help & reply. I have tried run the code that you have provided. But in mails which I am looking for & copy the body of the mail is more than the limit of single cell. I want to copy of mail body in different rows. I want to do a Paste Special as Text at B4 cell of excel. So it will split the mail body in different rows rather than in a single cell.
Thank you so much for your help & reply.
 
Paste Special is difficult as data needs to get into the clipboard, which is convoluted.
I suggest an alternative below; see how it goes.

Are you running this code from Excel? If so I don't think you need to create a new instance of excel, you can jusgt add a new workbook to the existing instance.
What version of Excel are you using?
I've added a line to highlight the start of each email on the sheet.
Code: 
Sub Mailbody_To_Excel3()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim myitem As Outlook.MailItem
Dim FileName As String
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim item As Object
Dim mail As MailItem
Dim vbody As String
Dim xlApp As Object  ' Excel.Application
Dim xlWkb As Object  ' Excel.Workbook

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
i = 0
If Inbox.Items.Count = 0 Then
  MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
End If
For Each item In Inbox.Items
  If item Like "*SubjectLineofmail*" Then  'remember this is case sensitive.
    If xlApp Is Nothing Then
      Set xlApp = CreateObject("Excel.Application")  ' New Excel.Application
      xlApp.Visible = True
      Set xlWkb = xlApp.Workbooks.Add
      Set DestnCell = xlApp.Range("B4")
    End If
    vbody = item.Body
    If Len(vbody) = 0 Then vbody = "Empty message"
    SplitBody = Split(Trim(vbody), vbCrLf)
    DestnCell.Interior.ColorIndex = 33  'delete his line if you don't want highlighting
    If UBound(SplitBody) > 0 Then DestnCell.Resize(UBound(SplitBody)).Value = Application.Transpose(SplitBody) Else DestnCell.Value = SplitBody
    Set DestnCell = xlApp.Cells(Rows.Count, DestnCell.Column).End(xlUp).Offset(2)
  End If
Next
If Not xlApp Is Nothing Then
  xlApp.ActiveWorkbook.SaveAs ("C:\Desktop\DailyReport_" & Format(Date, "MM-DD-YYYY") & ".xls")
  xlWkb.Close
  xlApp.Quit
  Set xlWkb = Nothing
  Set xlApp = Nothing
End If
Set objSearchFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
End Sub
 
Code: 
Sub M_snb()
  For Each it In CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6).Items
    c00 = c00 & string(3,vblf) & it.body
  Next
  sn=split(c00,vblf)

  sheet1.cells(1).resize(ubound(sn)+1)=application.transpose(sn)
End Sub
 
Last edited:
HiYou right I m running this code from Excel. I m using Excel 2007 version. Thanks.
 
then try (untested):
Code: 
Sub Mailbody_To_Excel4()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim i As Integer
Dim objSearchFolder As Outlook.MAPIFolder
Dim item As Object
Dim vbody As String
Dim xlWkb As Workbook  ' Excel.Workbook
Dim NewSht As Worksheet
Dim DestnCell As Range, SplitBody

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set objSearchFolder = Inbox
i = 0
If Inbox.Items.Count = 0 Then
  MsgBox "Inbox is Empty", vbInformation, "Nothing Found"
End If
For Each item In Inbox.Items
  If item Like "*SubjectLineofmail*" Then
    If xlWkb Is Nothing Then
      Set xlWkb = Workbooks.Add
      Set NewSht = xlWkb.Sheets(1)
      Set DestnCell = NewSht.Range("B4")
    End If
    vbody = item.Body
    If Len(vbody) = 0 Then vbody = "Empty message"
    SplitBody = Split(Trim(vbody), vbCrLf)
    DestnCell.Interior.ColorIndex = 33
    If UBound(SplitBody) > 0 Then DestnCell.Resize(UBound(SplitBody)).Value = Application.Transpose(SplitBody) Else DestnCell.Value = SplitBody
    Set DestnCell = NewSht.Cells(Rows.Count, DestnCell.Column).End(xlUp).Offset(2)
  End If
Next
If Not xlWkb Is Nothing Then
  xlWkb.SaveAs ("C:\Desktop\DailyReport_" & Format(Date, "MM-DD-YYYY") & ".xls")
  xlWkb.Close
  Set NewSht = Nothing
  Set xlWkb = Nothing
End If
Set objSearchFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
End Sub
 
Hello p45Cal,

Thanks for the reply. I tried your code, but I am getting an error message. Now I am trying this in otherway. I am trying to copy mail bod to temporary word document & then we paste it in to excel sheet as paste special text.

As in my mail messages I do have lots of data & I need to copy the mail body based on particular subject and then paste the mail body of related mail to excel sheet of that particular mail. There are 10sheets in excel which I need to update with the mailbody & proceed further.

I hope, you may have understand my requirement.

Thanks.
 
I'm not going change tack just yet; what error message? Does it happen after several emails have been pasted or right at the start? More info needed. Consider a Teamviewer session?
 
Hello P45CAL

Sorry I didn't reply to you. I was not well, had complete bedrest.

I have triggered the code to go through my outlook mailbox folders & search for the mail item which I am looking for based on the subject, copying the mail body to word & then opening the existing excel file ---> goes to desired destination sheet & cell. But I facing to paste the values copied from word to excel.

If you can help me with this the it will be big crack for me. Thank you so much for help.

Below are my updated codes


Code: 
Sub CopyfromOutlook()
 
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objfolder As Outlook.MAPIFolder
Dim wdDoc As Document
Dim oRng As Range
Dim olItem As Object
Dim fold As Variant
 
Set olApp = CreateObject("Outlook.Application") 'Create Outlook Object Set Inbox = olapp.getnamespace("mapi").Folders 'Create Outlook folder Object sysUserName = SystemLoginUSer()
myfoldname = "XYZ@XYZ.com"
Set Inbox = olApp.GetNamespace("mapi").Folders
    For Each fold In Inbox
        vFolderName = fold.Name
        If vFolderName = myfoldname Then
            flgFoldFound = True
            Exit For
        End If
    Next
   
    Set objparentfolder = fold
   
    Set colFolders = objparentfolder.Folders
    For Each objfolder In colFolders
        Set objsubfolder = objparentfolder.Folders(objfolder.Name)
        If objfolder.Name = "Inbox" Then
           'File_Path = getSavePath(objfolder, vID, vAction, fold_path)
            Exit For
        End If
    Next
   
   
    Set colFolders = objsubfolder.Folders
    For Each objfolder In colFolders
        Set objsubfolder1 = objsubfolder.Folders(objfolder.Name)
        If objfolder.Name = "Test" Then
           'File_Path = getSavePath(objfolder, vID, vAction, fold_path)
            Exit For
        End If
    Next
        Set Col = objfolder.Items
            iTotalMails = Col.Count
            I = iTotalMails
     
        For Each Item In objfolder.Items
           If Item Like "*Subject Line*" Then
           
            Set Currentitem1 = Item
           
            Documents("Test_Macro (Recovered)_1").Activate
           
            Selection.HomeKey Unit:=wdStory
            Selection.WholeStory
            Selection.Delete Unit:=wdCharacter, Count:=1
           
            Application.Selection.TypeText Text:=Currentitem1.Body
           
                  
            Selection.HomeKey Unit:=wdStory
            Selection.WholeStory
            Selection.Copy
       
       
        '************Excel Part***********
       
            Dim oExcel As Excel.Application
            Dim oWB As Workbook
            Dim oWBSheet As Worksheet
            Dim Rng As Range
            Set oExcel = New Excel.Application
            Set oWB = oExcel.Workbooks.Open("C:\Desktop\Test.xlsx")
            oExcel.Visible = True
 
            oWB.Sheets("01").Activate
            oWB.Sheets("01").Range("B4").Select
            Selection.PasteSpecial Link:=False, DataType:=wdPasteText, _
                Placement:=wdInLine, DisplayAsIcon:=False
           
           End If
        Next
End Sub
 
Last edited by a moderator:
Hi did you code end up working

I am trying to do something similar but only copy certain parts of the email.
 
You must log in or register to reply here.
Back
Top