使用 Excel VBA 将 Outlook 邮件中的表格整理到 Excel 工作表中

Question

我有一个 Excel 文件，它将用作从邮件中整理表格的工具。一封邮件中只有一张表和一条记录。我需要将所有此类表（来自不同邮件）中的记录整理到一个 Excel 表中。我有以下代码可以做到这一点。此代码在运行时将邮件正文中的整个文本复制到 Excel（因此，该代码仅在邮件具有表且邮件正文中没有其他文本时才有效）。但我只需要将邮件中的表格复制到 Excel。请帮我修改代码来做到这一点。请注意，我不想在 Outlook 中编写任何代码。复制的表格也粘贴为文本。我希望它们以表格格式粘贴。需要修改的部分代码如下所示。

    Public Sub ExportToExcel1()

Application.ScreenUpdating = False

'变量声明

Dim i As Integer
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim item As Object
Dim doClip As MSForms.DataObject
Dim d As String

'设置变量的值

i = 2
d = ActiveSheet.Range("subject").Value

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set doClip = New MSForms.DataObject

'循环检查邮件和提取数据

For Each item In Inbox.Items
    If TypeName(item) = "MailItem" And item.Subject = d Then
        doClip.SetText item.Body
        doClip.PutInClipboard
        ActiveSheet.Cells(1, 1).PasteSpecial "Text"

EndSub

Answer 1

你的代码有两个错误：

• 当您需要 Html 正文时，您可以访问文本正文 item.Body。
• 当您只需要表格时，将整个正文粘贴到工作表中。

你需要一些额外的变量：

  Dim Html As String
  Dim LcHtml As String
  Dim PosEnd As Long
  Dim PosStart As Long

将If 语句替换为：

    If TypeName(item) = "MailItem" And item.Subject = d Then

      Html = item.HTMLBody
      LcHtml = LCase(Html)
      PosStart = InStr(1, LcHtml, "<table")
      If PosStart > 0 Then
        PosEnd = InStr(PosStart, LcHtml, "</table>")
        If PosEnd > 0 Then
          Debug.Print "[" & Mid(Html, PosStart, PosEnd + 8 - PosStart) & "]"
          doClip.SetText Mid(Html, PosStart, PosEnd + 8 - PosStart)
          doClip.PutInClipboard
          ActiveSheet.Cells(1, 1).PasteSpecial "Text"
        End If
      End If

    End If