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

Question

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

在"收件箱"下有一个子文件夹其中所有类似的邮件都进来了。

我想根据电子邮件的主题提取数据，而不是为特定的电子邮件创建一个专用的子文件夹。

下面的代码。

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

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

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

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

将代码粘贴到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