Copy email to the clipboard with Outlook VBA

How do I copy an email to the clipboard and then paste it into excel with the tables intact?

I am using Outlook 2007 and I want to do the equivalent of

"Click on email > Select All > Copy > Switch to Excel > Select Cell > Paste". 

I have the Excel Object Model pretty well figured out, but have no experience in Outlook other than the following code.

Dim mapi As NameSpace
Dim msg As Outlook.MailItem
Set mapi = Outlook.Application.GetNamespace("MAPI")
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Ite开发者_运维知识库m(1).Folders.Item(7).Items.Item(526)

I must admit I use this in Outlook 2003, but please see if it works in 2007 as well:

you can use the MSForms.DataObject to exchange data with the clipboard. In Outlook VBA, create a reference to "Microsoft Forms 2.0 Object Library", and try this code (you can of course attach the Sub() to a button, etc.):

Sub Test()
Dim M As MailItem, Buf As MSForms.DataObject

    Set M = ActiveExplorer().Selection.Item(1)
    Set Buf = New MSForms.DataObject
    Buf.SetText M.HTMLBody
    Buf.PutInClipboard

End Sub

After that, switch to Excel and press Ctrl-V - there we go! If you also want to find the currently running Excel Application and automate even this, let me know.

There's always a valid HTMLBody, even when the mail was sent in Plain Text or RTF, and Excel will display all text attributes conveyed within HTMLBody incl. columns, colors, fonts, hyperlinks, indents etc. However, embedded images are not copied.

This code demonstrates the essentials, but doesn't check if really a MailItem is selected. This would require more coding, if you want to make it work for calendar entries, contacts, etc. as well.

It's enough if you have selected the mail in the list view, you don't even need to open it.

I finally picked it up again and completely automated it. Here are the basics of what I did to automate it.

Dim appExcel As Excel.Application
Dim Buf As MSForms.DataObject
Dim Shape As Excel.Shape
Dim mitm As MailItem
Dim itm As Object
Dim rws As Excel.Worksheet
'code to open excel
Set appExcel = VBA.GetObject(, "Excel.Application") 
'...
'code to loop through emails here       
Set mitm = itm
body = Replace(mitm.HTMLBody, "http://example.com/images/logo.jpg", "")
Call Buf.SetText(body)
Call Buf.PutInClipboard
Call rws.Cells(i, 1).PasteSpecial
For Each Shape In rws.Shapes
    Shape.Delete 'this deletes the empty shapes
Next Shape
'next itm

I removed the logo urls to save time, and when you're dealing with 300 emails, that translates into at least ten minutes saved.

I got the code I needed from a TechRepublic article, and then changed it to suit my needs. Many thanks to the accepted answerer of this question for the clipboard code.

Ok so I will have to make certain assumptions because there is information missing from your question. Firstly you didn't say what mailformat the message is... HTML would be the easiest, the process will be different for RTF and not possible in plaintext Since you are refering to tables I will assume they are HTML tables and the mail format is HTML.

Also it is not clear from your question if you want the table content pasted seperately (1 excel cell per table cell) and the rest of the emails bodytext pasted into 1 cell or several?

finally you haven't really said if you want the VBA running from Outlook or Excel (not that important but it affects which intrinsic objects are available.

Anyway code sample: Outlook code to access the htmlbody prop

Dim mapi As Namespace
Set mapi = Application.Session
Dim msg As MailItem
Set msg = mapi.Folders.Item(1).Folders.Item("Posteingang").Folders.Item(1).Folders.Item(7).Items.Item(526) 
Dim strHTML as String
strHTML = msg.HTMLBody
' There is no object model collection for html tables within the htmlbody (which is a string of html) you will need to parse the html and collect the tables before inserting into Excel.

After a while again, I found another way. MailItem.Body is plain text, and has a tab character between table cells. So I used that. Here is the gist of what I did:

Sub Import()
    Dim itms As Outlook.Items
    Dim itm As Object
    Dim i As Long, j As Long
    Dim body As String
    Dim mitm As Outlook.MailItem
    For Each itm In itms
        Set mitm = itm
        ParseReports (mitm.body) 'uses the global var k
    Next itm
End Sub
Sub ParseReports(text As String)
    Dim table(1 To 1000, 1 To 11) As String 'I'm not expecting to see a thousand rows!
    Dim drow(1 To 11) As String
    For Each Row In VBA.Split(text, vbCrLf)
        j = 1
        For Each Col In VBA.Split(Row, vbTab)
            table(i, j) = Col
            j = j + 1
        Next Col
        i = i + 1
    Next Row
    For i = 1 To l
        For j = 1 To 11
            drow(j) = table(i, j)
        Next j
        hws.Range(hws.Cells(k, 1), hws.Cells(k, 11)) = drow
        k = k + 1
    Next i
End Sub

Average: 77 emails processed per second. I do some minor processing and extracting.