How do I include reply's when reading outlook email with VBA? - vba

Question

I'm reading Outlook Inbox and Sent folder emails for a given address and populating an Access table. My routine isn't picking up the "Reply" emails. I assumed they would be in the sent folder. I don't have any subfolders at this time. Any thoughts on what I'm missing or don't understand? This is my first venture into reading Outlook data.
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

Here is what I found that works. The list of recipient address for a sent email are found here. For each email item, I call this function to see if the address I'm looking for was in the list of recipients.
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