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

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

1 个答案: