将 Outlook 收件箱文件夹中的数据提取到 Excel 中

Question

我有一个名为“Customer”的 Excel 文件。其中包含“名称”列（A 列）和“电子邮件”列（D 列）。 “电子邮件”栏当前为空。

我想通过将 A 列中的名称与 Outlook 收件箱文件夹中的名称相匹配来填写“电子邮件”列。当名称匹配时，搜索该名称的电子邮件地址，将其复制并粘贴回客户表电子邮件列（D 列）。用vba可以做到吗？

我尝试了以下代码，但它现在已经运行了 4 个小时，我不确定它是否正常工作。

Sub FillEmails()
    Dim customerSheet As Worksheet
    Dim customerLastRow As Long
    Dim customerName As String
    Dim customerEmail As String
    Dim olApp As Object
    Dim olNamespace As Object
    Dim olFolder As Object
    Dim olItems As Object
    Dim olItem As Object
    Dim i As Long

    Set customerSheet = ThisWorkbook.Sheets("Customer")
    
    ' Create an instance of the Outlook application and get the namespace and folder objects
    Set olApp = CreateObject("Outlook.Application")
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(6) ' olFolderInbox
    Set olItems = olFolder.Items

    customerLastRow = customerSheet.Cells(Rows.Count, "A").End(xlUp).Row

    For i = 2 To customerLastRow
        customerName = customerSheet.Cells(i, "A").Value
        customerEmail = ""

        ' Search for an email with a matching sender name in the default Inbox folder
        For Each olItem In olItems
            If olItem.Class = 43 Then ' olMail
                If olItem.SenderName = customerName Then
                    customerEmail = olItem.SenderEmailAddress
                    Exit For
                End If
            End If
        Next

        customerSheet.Cells(i, "D").Value = customerEmail
    Next i
    
    ' Clean up the Outlook objects
    Set olItems = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
End Sub

Answer 1

首先，迭代文件夹中的所有项目并不是一个好主意：

For i = 2 To customerLastRow
        customerName = customerSheet.Cells(i, "A").Value
        customerEmail = ""

        ' Search for an email with a matching sender name in the default Inbox folder
        For Each olItem In olItems
            If olItem.Class = 43 Then ' olMail
                If olItem.SenderName = customerName Then
                    customerEmail = olItem.SenderEmailAddress
                    Exit For
                End If
            End If
        Next

        customerSheet.Cells(i, "D").Value = customerEmail
    Next i

相反，您需要使用

Find

类的

FindNext

/

Restrict

或

Items

方法。它们允许获取与指定搜索条件相对应的项目，因此您无需迭代文件夹中的所有项目。在我为技术博客撰写的文章中阅读有关这些方法的更多信息：

• 如何：使用 Find 和 FindNext 方法从文件夹中检索 Outlook 邮件项目 (C#、VB.NET)
• 如何：使用限制方法从文件夹中检索 Outlook 邮件项目

DASL 支持使用内容索引器关键字

ci_startswith

和

ci_phrasematch

以及关键字 like 来匹配字符串属性中的前缀、短语和子字符串。因此，您可以尝试通过以下方式查找关键字：

criteria = "@SQL=" & Chr(34) _ 
& "urn:schemas:httpmail:sendername" & Chr(34) _ 
& " ci_phrasematch 'sender_name'" 

sendername

属性返回消息发送者的显示名称。该字段对应于

RFC 822 Sender: header for a message

。

---

其次，您可以尝试使用 NameSpace.CreateRecipient 方法来创建

Recipient

对象。它接受收件人的姓名；它可以是表示收件人的显示名称、别名或完整 SMTP 电子邮件地址的字符串。因此，在根据地址簿解析收件人后，您可以尝试获取电子邮件地址（请参阅相应的属性）。

Recipient.Resolve 方法尝试根据地址簿解析

Recipient

对象。 Recipient.Resolved 属性返回一个布尔值，指示

true

收件人是否已根据地址簿进行验证，例如：

Sub ResolveName() 
 Dim myNamespace As Outlook.NameSpace 
 Dim myRecipient As Outlook.Recipient 
 Dim CalendarFolder As Outlook.Folder 
 Set myNamespace = Application.GetNamespace("MAPI") 
 Set myRecipient = myNamespace.CreateRecipient("Eugene Astafiev") 
 
 myRecipient.Resolve 
 
 If myRecipient.Resolved Then 
   MsgBox myRecipient.Address 
 End If 
 
End Sub