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.Item(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.