如何使用 VBA 根据电子邮件主题提取 Outlook 电子邮件数据？

Question

我有从 Outlook 电子邮件中提取表格的 VBA 代码。

我在“收件箱”下有一个子文件夹，所有类似的邮件都在其中。

我想根据电子邮件的主题提取数据，而不是为该特定电子邮件设置专用子文件夹。

代码如下。

Option Explicit

Sub ImportTable()

Cells.Clear
Dim OLApp As Outlook.Application
'Set OA = CreateObject("Outlook.Application")
Set OLApp = New Outlook.Application

Dim ONS As Outlook.Namespace
Set ONS = OLApp.GetNamespace("MAPI")
Dim myFolder As Outlook.Folder
Set myFolder = ONS.Folders("emailaddress").Folders("Inbox")
Set myFolder = myFolder.Folders("Others")
Dim OLMAIL As Outlook.MailItem
Set OLMAIL = OLApp.CreateItem(olMailItem)

For Each OLMAIL In myFolder.Items
    Dim oHTML As MSHTML.HTMLDocument
    Set oHTML = New MSHTML.HTMLDocument
    Dim oElColl As MSHTML.IHTMLElementCollection
    With oHTML
        .Body.innerHTML = OLMAIL.HTMLBody
        Set oElColl = .getElementsByTagName("table")
    End With

    Dim t As Long, r As Long, c As Long
    Dim eRow As Long

    For t = 0 To oElColl.Length - 1
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For r = 0 To (oElColl(t).Rows.Length - 1)
            For c = 0 To (oElColl(t).Rows(r).Cells.Length - 1)
                Range("A" & eRow).Offset(r, c).Value = oElColl(t).Rows(r).Cells(c).innerText
            Next c
        Next r
        eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
    Next t
        
    'Cells(eRow, 1) = "Sender's Name:" & " " & OLMAIL.Sender
    'Cells(eRow, 1).Interior.Color = vbRed
    'Cells(eRow, 1).Font.Color = vbWhite
    Cells(eRow, 1) = "Date & Time of Receipt:" & " " & OLMAIL.ReceivedTime
    Cells(eRow, 1).Interior.Color = vbRed
    Cells(eRow, 1).Font.Color = vbWhite
    Cells(eRow, 1).Columns.AutoFit
        
Next OLMAIL

Range("A1").Select

Set OLApp = Nothing
Set OLMAIL = Nothing
Set oHTML = Nothing
Set oElColl = Nothing

On Error Resume Next
Range("A1:A" & Worksheets(1).UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'ThisWorkbook.VBProject.VBE.MainWindow.Visible = False

End Sub

Answer 1

如果您想处理收到的电子邮件，请查看我在上面评论中的网站链接。

如果你想处理当前项目，有几种方法可以做到。这是我最近发现的一种方法，它很棒，我正在使用它！点击here进入网站。

我已根据您的需要进行了修改。如果你有不同的主题，确定要提取的内容也会不同，因此它会检查当前项目并根据主题运行特定的宏。

将代码粘贴到 ThisOutlookSession 模块中

Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
  
Private Sub Application_Startup()
 Set m_Inspectors = Application.Inspectors
End Sub
  
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
 If TypeOf Inspector.currentItem Is Outlook.MailItem Then
  'Handle emails only
  Set m_Inspector = Inspector
 End If
End Sub
  
Private Sub m_Inspector_Activate()
    Dim Item As MailItem
    
    If TypeOf m_Inspector.currentItem Is MailItem Then
        Set Item = m_Inspector.currentItem
        
        With Item
            ' Display mail
            '.Display
            
            ' Mails with filled opions
            Select Case .subject
                Case "mySubject_01"
                    Call Macro_01
                    
                Case "mySubject_02"
                    Call Macro_02
                    
                Case "mySubject_03"
                    Call Macro_03
            End Select
            
            Set Item = Nothing
        End With
    End If
End Sub