使用 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 Object Library ”的引用，并尝试以下代码（您当然可以将 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 应用程序并自动执行此操作，请告诉我。

始终存在有效的 HTMLBody，即使邮件以纯文本或 RTF 格式发送，Excel 也会显示 HTMLBody 中传达的所有文本属性，包括。 列、颜色、字体、超链接、缩进等。但是，不会复制嵌入的图像。

此代码演示了基本要素，但不检查是否真的选择了 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

我删除了徽标网址以节省时间，当您处理 300 封电子邮件时，这意味着至少节省了十分钟。

我从TechRepublic 的一篇文章中获得了我需要的代码，然后对其进行了更改以满足我的需要。 非常感谢剪贴板代码这个问题的公认回答者。

Answer 3

又过了一会儿，我找到了另一种方法。 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 封电子邮件。 我做了一些小的处理和提取。

Answer 4

好的，所以我将不得不做出某些假设，因为您的问题中缺少信息。 首先，您没有说明邮件是什么邮件格式... HTML 将是最简单的，RTF 的过程会有所不同，并且不可能在纯文本中 因为您指的是表格，所以我假设它们是 HTML 表格，邮件格式是HTML。

从您的问题中也不清楚您是否希望单独粘贴表格内容（每个表格单元格 1 个 excel 单元格）并将其余的电子邮件正文粘贴到 1 个或多个单元格中？

最后，您还没有真正说过是否希望从 Outlook 或 Excel 运行 VBA（不是那么重要，但它会影响哪些内部对象可用。

无论如何代码示例：访问 htmlbody 道具的 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.