将电子邮件复制到使用Outlook VBA的剪贴板

Question

如何将电子邮件复制到剪贴板，然后将其完整地粘贴到Excel中？

我正在使用Outlook 2007，我想做等同于

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

我的Excel对象模型已经很好地弄清楚了，但是 不 除了以下代码外，Outlook的经验。

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)

Answer 1

我必须承认我在Outlook 2003中使用了此功能，但是请查看它是否在2007年也有效：

您可以使用 msforms.dataObject 与剪贴板交换数据。在Outlook VBA中，创建对“Microsoft Forms 2.0对象库”，尝试此代码（您当然可以将sub（）附加到按钮等）：

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

之后，切换到Excel，然后按Ctrl -V-我们走了！如果您还想找到当前正在运行的Excel应用程序并使此功能自动化，请告诉我。

即使以纯文本或RTF发送邮件，也总是有一个有效的HTML机体，Excel将显示HTML Body Incl中传达的所有文本属性。列，颜色，字体，超链接，凹痕等。但是，没有复制嵌入式图像。

该代码演示了必需品，但没有检查是否真正选择了MailItem。如果您想使其适用于日历条目，联系人等，这将需要更多的编码。

如果您在列表视图中选择了邮件，就足够了，甚至不需要打开它。

Answer 2

我终于再次捡起它，并完全自动化它。这是我为自动化它所做的基础知识。

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

我删除了徽标URL 为了省时间, ，当您处理300封电子邮件时，将至少保存十分钟。

我从中得到了我需要的代码 Techrepublic文章, ，然后更改它以满足我的需求。非常感谢剪贴板代码的此问题的答复器。

Answer 3

好的，所以我必须做出某些假设，因为您的问题中缺少信息。首先，您没有说邮件是什么邮件... html是最简单的，对于RTF而言，该过程将是不同的，并且由于您指的是表，因此无法以纯文本为单位html。

另外，从您的问题中还不清楚您是否要单独粘贴表内容（每个表单元格1 Excel单元格），而其余的电子邮件BodyText粘贴到1个单元格中？

最后，您并没有真正说过如果您想从Outlook或Excel运行VBA（并不重要，但它会影响哪些内在对象可用。

无论如何代码示例：访问HTMLBody Prop的Outlook代码

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.

Answer 4

再过一会儿，我找到了另一种方式。 mailItem.Body是纯文本，在表单元格之间具有标签字符。所以我用了。这是我所做的要旨：

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

平均：77封电子邮件 处理 每秒。我做一些小的处理和提取。