将特定日期和主题的表格从 Outlook 邮件复制到 Excel

Question

我每天都会收到一封主题为“电子邮件主题 ABC”的电子邮件，其中有一个表格。有时我会将此表复制到 Excel 中来处理数据。

我想使用宏从指定日期提取电子邮件主题为“电子邮件主题 ABC”的表格，并将其复制到当前打开的工作簿中名为“Tab DEF”的工作表选项卡的单元格 B2 中。

我得到：

运行时错误“13”：
类型不匹配

带有

Next olMail

的行突出显示。

Option Explicit

Sub ExportOutlookTableToExcel()

Dim olNS As Outlook.Namespace
Dim olInspector As Outlook.Inspector
Dim olMailItem As Outlook.MailItem
Dim olInboxFolder As MAPIFolder
Dim olItems As Outlook.Items
Dim olMailCount As Integer
Dim i As Integer

'Declare Excel Variables
Dim olWordDoc As Word.Document
Dim olWordTable As Word.Table

'Declare Excel Variables
Dim xlBook As Excel.Workbook
Dim xlWorksheet As Excel.Worksheet

Set olNS = GetNameSpace("MAPI")
Set olInboxFolder = olNS.GetDefaultFolder(olInboxFolder)
Set olItems = olInboxFolder.Items

i = 1
olMailCount = olItems.Count

Dim Start_date As Date
Dim End_date As Date

Start_date = #12/8/2020# + TimeSerial(5, 0, 0)
End_date = #12/10/2020# + TimeSerial(5, 0, 0)

'Searching every item in the inbox
For Each olItems In olInboxFolder.Items
    If olItems.CreationTime >= Start_date And olItems.CreationTime <= End_date Then
        If olItems.Subject = "Email subject" Then

            Set olInspector = olItems.GetInspector

            Set olWordDoc = olInspector.WordEditor

            Set xlBook = ThisWorkbook

            Set xlWorksheet = xlBook.Worksheet("Worksheet_tab")

            Set olWordTable = olWordDoc.Tables(1)

            olWordTable.Range.Copy

            xlWorksheet.Paste Destination:=xlWorksheet.Range("B2")

        End If
    End If
Next olItems

End Sub

Answer 1

理论解。在我的机器上不实用。

• 每次迭代生成多条消息“代码执行已被中断”。
• 可以强制 Outlook 重新启动

先前的问题表明不可靠将表从 Outlook 电子邮件复制到 Excel 文件 - VBA。

Option Explicit

Sub ExportOutlookTableToExcel()

Dim olInspector As Inspector
Dim olInboxFolder As folder

Dim olItems As items
Dim olItem As Object

Dim olWordDoc As Word.Document
Dim olWordTable As Word.Table

'Declare Excel Variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlWorksheet As Excel.Worksheet

'Create a new Excel workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True

Set olInboxFolder = Session.GetDefaultFolder(olFolderInbox)
Set olItems = olInboxFolder.items

Dim Start_date As Date
Dim End_date As Date

Start_date = #7/31/2022# + TimeSerial(5, 0, 0)
Debug.Print " Start_date: " & Start_date

End_date = #8/15/2022# + TimeSerial(5, 0, 0)
Debug.Print " End_date: " & End_date

'Continue (or debug) when there is a message.
' "Code execution has been interrupted"

'For efficiency, implement a Restrict on the dates.
' https://stackoverflow.com/questions/63884195
' This as well will reduce the number of messages.

For Each olItem In olInboxFolder.items
    
    If olItem.Class = olMail Then
    
        If olItem.CreationTime >= Start_date Then
        
            If olItem.CreationTime <= End_date Then
            
                If olItems.subject = "Email subject" Then
                
                    Debug.Print olItem.subject
                    Debug.Print " CreationTime: " & olItem.CreationTime
                                                            
                    Set olInspector = olItem.GetInspector
                    Set olWordDoc = olInspector.WordEditor
                    
                    If olWordDoc.Tables.Count > 0 Then
                        Set olWordTable = olWordDoc.Tables(1)
                        
                        Set xlBook = xlApp.Workbooks.Add
                        Set xlWorksheet = xlBook.Sheets(1)
                        
                        olWordTable.Range.Copy
                        xlWorksheet.Paste Destination:=xlWorksheet.Range("B2")
                        
                        Debug.Print " Table saved."
                        
                    Else
                        Debug.Print " Table not found. ****"
                        
                    End If 
                End If
            End If
        End If
    End If
Next

Debug.Print "Done."

End Sub