How to get Sent message dates using VBA?

[deko]

Id like to keep a Table in Access that lists all the dates on which an email
was sent or received to each contact. I keep the contacts in my Access
database synchronized with the Outlook Contact folder with code that runs
every time the database is open - I upload all the relevant contact info
(email address, etc.) and an Entity_ID (which goes in the "Department"
field) to the Outlook Contacts folder. What I need is a way to pull down
all the dates in "Sent" and "Received" fields in the InBox and Sent Items
folder - based on the Entity_ID in the Outlook Contacts form. Here's first
crack at it... any help is much appreciated.

Dim rst as DAO.Recordset
Dim db as DAO.Database
Dim olns as Outlook.Namspace
Dim os as New Outlook.Application
Dim ib, cn as Outlook.MAPIFolder
Dim objItems as Outlook.Items

Set olns = ol.GetNamespace("MAPI")
Set si = olns.GetDefaultFolder(olFolderSentItems)
set cn = olns.GetDefaultFolder(olFolderContacts)
Set objItems = cn.Items
Set rst = db.OpenRecordset("tblEmail")

For Each varId In cn.Items

'look up messages in Sent Items based on ID in Contacts folder

If cn.Items has email message in Sent Items folder Then
'(pseudo code)
varSent = DateSent
End If

'get dates from Sent Items folder based on ID and put into table

rst.AddNew
rst!Entity_ID = varId.Department
rst!Sent = DateValue(CDate(varSent))
rst.Update
Next

 

[deko]

okay, making progress. But how do I get MailItem.SentOn and
MailItem.Subject for a *particular* Contact entry? Outlook must know if a
particular contact entry has email messages in the PST - if I open an email
message in the InBox and right click on the From header, I can right click
and select "Lookup Contact" from the menu and it will take me to that
contact's entry in the Contacts folder. What I am trying to do is the same
process in reverse.

Here is beta 2:

Dim olns As Outlook.Namespace
Dim ola As New Outlook.Application
Dim olfcn, olfsm As Outlook.MAPIFolder
Dim olci As Outlook.ContactItem
Dim olmi As Outlook.MailItem
Dim olit As Outlook.Items
Dim varItem As Variant
Dim varEid As Variant
Dim varSent As Variant
Dim strSubject As String

Set olns = ola.GetNamespace("MAPI")
Set olfsm = olns.GetDefaultFolder(olFolderSentMail)
Set olfcn = olns.GetDefaultFolder(olFolderContacts)
Set olit = olfsm.Items
Set olmi = olit.GetLast

For Each varItem In olfcn.Items
If Not IsNull(varItem.Body) And IsNumeric(varItem.Body) And
varItem.Body = 114 Then
'get all MailItem.SentOn and Subject entries for contact 114
Debug.Print "found Entity ID " & varItem.Body 'returns "found
Entity ID 114"
Debug.Print "found MailItem " & olit.Item(1) 'returns first
subject in PST (by date ascending)
Debug.Print "found MailItem " & olmi.SentOn 'returns date of
last email sent in PST (by date descending)
End If
Next

 

[deko]

beta 3...................

Public Sub GetMessages()

Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim olns As Outlook.Namespace
Dim ola As New Outlook.Application
Dim olfcn, olfsm As Outlook.MAPIFolder
Dim olci As Outlook.ContactItem
Dim olmi As Outlook.MailItem
Dim olit As Outlook.Items
Dim varC, varM As Variant
Dim varEid As Variant
Dim varSent As Variant
Dim strSubject As String

Set olns = ola.GetNamespace("MAPI")
Set olfsm = olns.GetDefaultFolder(olFolderSentMail)
Set olfcn = olns.GetDefaultFolder(olFolderContacts)
Set olit = olfsm.Items
Set olmi = olit.GetLast

For Each varC In olfcn.Items

'loop through each Contact in the Contacts folder where there is an
Entity_ID

If Not IsNull(varC.Body) And IsNumeric(varC.Body) Then
Debug.Print "varC EntryID = " & varC.EntryID
Debug.Print varC.Email1Address
'Debug.Print varC.Display 'this brings up Outlook Contact form
'Debug.Print "olmi.To = " & olmi.To 'most recent email sent
(regardless of Entity_ID)

'this appears to match olmi.To
Debug.Print _
varC.FirstName & " " & _
varC.LastName & " " & _
varC.Suffix & _
"(" & varC.Email1Address & ")"

Debug.Print vbCrLf

'now loop through each MailItem and find those that belong to each
contact
'this does not work...

For Each varM In olfsm.Items

'the problem here is finding a way to match the MailItem with the
ContactItem
'the only criteria I can find to match on is "To"
'I tried EntryID - but they differ between contactItem and MailItem
'If I could get the email address out of the MailItem, that would help -
I think

'If olmi.EntryID = varC.EntryID Then
'If olmi.To = varC.Email1Address Then
If olmi.To = _
varC.FirstName & " " & _
varC.LastName & " " & _
varC.Suffix & _
"(" & varC.Email1Address & ")" _
Then
'Debug.Print "found MailItem " & olit.Item(1) 'returns
first subject in PST by date ascending
Debug.Print olmi.To 'returns most recent email date sent
in PST

'here I would put in code to populate Access table...

End If
Next
End If
Next

Exit Sub

'populate table with MailItem data
Set rst = db.OpenRecordset("tblEmail")
rst.AddNew
rst!Entity_ID = olci.Body
rst!Sent = DateValue(CDate(varSent))
rst.Update

End Sub