Question

我正在阅读给定地址的Outlook收件箱和已发送文件夹电子邮件，并填充Access表。我的例行程序没有收到“回复”电子邮件。我以为他们会在发送文件夹中。我目前没有任何子文件夹。关于我遗失或不理解的任何想法？这是我第一次尝试阅读Outlook数据。

Sub GetFromInbox(strInboxSent As String, strForAddress As String)
    Dim olFolderInboxSent As Integer

    Select Case strInboxSent
        Case "InBox"
            olFolderInboxSent = 6   '6 = InBox, Sent = 5
        Case "Sent"
            olFolderInboxSent = 5   
    End Select

    Dim olApp As Object, olNs As Object
    Dim oRootFldr As Object ' Root folder to start
    Dim lCalcMode As Long

    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set oRootFldr = olNs.GetDefaultFolder(olFolderInboxSent) 

    GetFromFolder oRootFldr, strForAddress, olFolderInboxSent
    Set oRootFldr = Nothing
    Set olNs = Nothing
    Set olApp = Nothing
End Sub

Private Sub GetFromFolder(oFldr As Object, strForAddress As String, intInboxSent As Integer)

    'Load Worktable with sent emails
    Dim cmd As ADODB.Command
    Dim rst As ADODB.Recordset
    Set cmd = New ADODB.Command
    cmd.ActiveConnection = CurrentProject.Connection

    Set rst = New ADODB.Recordset
    rst.LockType = adLockOptimistic
    cmd.CommandText = "Select * From wtblEmails"
    rst.Open cmd

    Dim oItem As Object, oSubFldr As Object

    ' Process all mail items in this folder
    For Each oItem In oFldr.Items
    Debug.Print TypeName(oItem)
        If TypeName(oItem) = "MailItem" Then
            With oItem
                Select Case intInboxSent
                    Case 6
                        If .SenderEmailAddress = strForAddress Then
                            'Debug.Print .Subject, .SenderName, .SenderEmailAddress, .EntryID
                            rst.AddNew
                            rst!weDate = .CreationTime
                            rst!weRcvdSent = "R"
                            rst!weWith = .SenderEmailAddress
                            rst!weSubject = .Subject
                            rst!weBody = .Body
                            rst!weid = .EntryID
                            rst.Update
                        End If
                    Case 5
                        If .To = strForAddress Then
                            'Debug.Print .Subject, .SenderName, .SenderEmailAddress, .EntryID
                            rst.AddNew
                            rst!weDate = .CreationTime
                            rst!weRcvdSent = "S"
                            rst!weWith = .To
                            rst!weSubject = .Subject
                            rst!weBody = .Body
                            rst!weid = .EntryID
                            rst.Update
                        End If
                    End Select
            End With
        End If
    Next

    ' Recurse all Subfolders
    For Each oSubFldr In oFldr.Folders
        GetFromFolder oSubFldr, strForAddress, intInboxSent
    Next
End Sub

Answer 1

这是我发现的有效方法。可在此处找到已发送电子邮件的收件人地址列表。对于每个电子邮件项目，我都会调用此函数来查看我要查找的地址是否在收件人列表中。

Public Function fncWasMailSentTo(mail As Outlook.MailItem, strAddress As String) As Boolean
    Dim recips As Outlook.Recipients
    Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set recips = mail.Recipients

    fncWasMailSentTo = False

    For Each recip In recips
        Set pa = recip.PropertyAccessor
        'Debug.Print recip.Name & " SMTP=" & pa.GetProperty(PR_SMTP_ADDRESS)
        If pa.GetProperty(PR_SMTP_ADDRESS) = strAddress Then
            fncWasMailSentTo = True
            Exit For
        End If
    Next
End Function

在使用VBA阅读outlook电子邮件时，如何包含回复？

1 个答案: