Page 1 of 2 1 2 LastLast
Results 1 to 10 of 12

Thread: Help on VBA Code to copy mail body to excel spreadsheet

  1. #1

    Post Help on VBA Code to copy mail body to excel spreadsheet



    Register for a FREE account, and/
    or Log in to avoid these ads!

    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

  2. #2
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,478
    Articles
    0
    Excel Version
    365
    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

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

  4. #4
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,478
    Articles
    0
    Excel Version
    365
    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

  5. #5
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    374
    Articles
    0
    Excel Version
    2020
    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 by snb; 2015-01-29 at 04:00 PM.

  6. #6
    HiYou right I m running this code from Excel. I m using Excel 2007 version. Thanks.

  7. #7
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,478
    Articles
    0
    Excel Version
    365
    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

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

  9. #9
    Super Moderator p45cal's Avatar
    Join Date
    Dec 2012
    Posts
    1,478
    Articles
    0
    Excel Version
    365
    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?

  10. #10
    Conjurer snb's Avatar
    Join Date
    May 2013
    Posts
    374
    Articles
    0
    Excel Version
    2020
    Did you overlook #5 ?

Page 1 of 2 1 2 LastLast

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •