Outlook Object Model Limitation

[deko]

This code will pull (from the Sent Items folder) the Address, Subject, and
Date Sent of each message sent to each Contact (that has an email address)
in the default Outlook Contacts folder. This data is intended to be
imported into an Access mdb which is synchronized with the Outlook Contacts
folder. This "Messages Sent" summary would then be associated with it's
respective contact in the database.

The problem is speed - with 39 messages in my Sent Items folder, and less
than 50 contacts, this took about 5 minutes to run on a 1.5Ghz P4 with 512
Ram. I believe this is due to the fact that every message in the Sent Items
folder has to be replied to - for each contact.

As is stated in KB article 324530: "The inability to directly return a fully
qualified e-mail address is a limitation of the Outlook object model."

Any suggestions on how to improve this are welcome!

Public Sub GetMessages()
Dim olns As Outlook.Namespace
Dim ola As New Outlook.Application
Dim olfcn, olfsm As Outlook.MAPIFolder
Dim olci As Outlook.ContactItem
Dim olmi, olmiRa As Outlook.MailItem
Dim varC As Variant
Dim olra As Outlook.Recipient
Dim olrsa As Outlook.Recipients
Set olns = ola.GetNamespace("MAPI")
Set olfsm = olns.GetDefaultFolder(olFolderSentMail)
Set olfcn = olns.GetDefaultFolder(olFolderContacts)
For Each varC In olfcn.Items
For Each olmi In olfsm.Items
Set olmiRa = olmi.ReplyAll
Set olrsa = olmiRa.Recipients
For Each olra In olrsa
If olra.Address = varC.Email1Address Then
Debug.Print "----------------------------"
Debug.Print "sent to: " & olra.Address
Debug.Print "sent on: " & olmi.SentOn
Debug.Print "subject: " & olmi.Subject
Debug.Print "----------------------------"
End If
Next
Set olmiRa = Nothing
Set olrsa = Nothing
Next
Next
Set olns = Nothing
Set olfsm = Nothing
Set olfcn = Nothing
End Sub

 

[deko]

Performance improved - this new code was tested using (an Access 2003 mdb
with) a contact entry with 3 different email addresses. It took 50 seconds
(1.5Ghz P4 with 512 RAM) to find 8 messages out of the 1125 in the Outlook
Sent Items folder that were sent to either of the 3 addresses in question.
For a contact with 1 email address, run time was 18 seconds.

Public Sub SentMessages()
On Error GoTo HandleErr
Dim rst, rste As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim db As DAO.Database
Dim olns As Outlook.Namespace
Dim ola As New Outlook.Application
Dim olfsm As Outlook.MAPIFolder
Dim olmi As Outlook.MailItem
Dim olr As Outlook.Recipient
Dim olrs As Outlook.Recipients
Dim strE, strR, j, i As String
DoCmd.Hourglass True
Set db = CurrentDb
Set olns = ola.GetNamespace("MAPI")
Set olfsm = olns.GetDefaultFolder(olFolderSentMail)
Set rst = db.OpenRecordset("tblEmailSent")
Set qdf = db.QueryDefs("qryEmailSentR")
For Each prm In qdf.Parameters
prm.Value = Eval(prm.Name)
Next prm
Set rste = qdf.OpenRecordset(dbOpenSnapshot)
rste.MoveFirst
Do Until rste.EOF 'look for each email address that belongs to this
contact
If InStr(rste!EmailAddress, "#") Then 'ignore comments preceeded by
" #"
j = InStr(rste!EmailAddress, "#")
i = "2"
Else
j = Nz(Len(rste!EmailAddress), 0)
i = "0"
End If
strE = (Left(rste!EmailAddress, j - i)) 'look for this address as a
recipient
For Each olmi In olfsm.Items 'check every message in the Sent Items
folder
DoEvents
Set olrs = olmi.Recipients
For Each olr In olrs 'check every recipient the message was sent
to
If olr.Address = strE Then
'Debug.Print "found olr.Address [" & olr.Address & "]"
rst.AddNew 'send matching results to tblEmailSent
rst!Sent = (CDate(olmi.SentOn))
rst!Subject = olmi.Subject
rst!Recipient = strE
rst.Update
End If
Next
Next
rste.MoveNext
Loop
Exit_here:
DoCmd.Hourglass False
rst.Close
rste.Close
Set olrs = Nothing
Set olns = Nothing
Set olfsm = Nothing
Set rst = Nothing
Set rste = Nothing
Set qdf = Nothing
Set db = Nothing
Exit Sub
HandleErr:
Select Case Err.Number
Case 3021 'No current record. - if Access contact has no email
addresses
Resume Exit_here
Case Else
modHandler.LogErr ("modOutlook(SentMessages)")
Resume Exit_here
End Select
End Sub