CDO Loop problem - Fix could be useful for many people.

[sam.male]

I have code that works for what I am doing but I need some help
cleaning it up. I am calling this procedure from a button on an
Access form. When the user clicks the button, the procedure loops
through all of the inbox mail and compares the sender addresses to the
email address in a textbox on the form. For each match, it adds the
body of the email to a subform on the Access form. I am storing
emails from people whose demographics are kept in the database.

Although my code works, it is tripping the Outlook OMG Security
warning twice. The first OMG is from starting the Outlook session,
which I use to loop through the Inbox folder. The second OMG is for
the CDO session I use to get the correct email address format of
"(e-mail address removed)" versus getting the sender returned as "John Doe"
via the Outlook session. Also, this code is slow. Now that we know
what I want to do....how can I fix it?

By the way....it would be cool to add a snippit that would loop
through emails only 6 months old vs the whole Inbox. This is not a
super-sophisticated procedure, but if I can get it figured out, many
people may find it helpful. Try to be specific in your response as my
coding skills are intermediate (not advanced). Thanks in advance for
help. Please also reply to sjstephens (at) bethesda.med.navy.mil

--Sam

Here is my code:

Private Sub CheckMail()
'Open Outlook
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim OlApp As Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Set fld =
OlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

'Start CDO session
Dim objSession As MAPI.Session
Dim objCDOMsg As MAPI.Message
Dim strEntryID As String
Dim strStoreID As String
Set objSession = CreateObject("MAPI.Session")
objSession.Logon , , False, False

'Declarations for Adding to Recordset
Dim db As DAO.Database
Set db = CurrentDb
Dim TempRst As DAO.Recordset
Set TempRst = CurrentDb.OpenRecordset("tblDirectAccessionsdetail")

On Error Resume Next

'Get address from form for comparison to Inbox email during loop
Dim txtemail As String
txtemail = Me!DAEmail

'Loop Through Inbox
For Each itm In fld.Items

'Get information about email
strEntryID = itm.EntryID
strStoreID = itm.Parent.StoreID
Set objCDOMsg = objSession.GetMessage(strEntryID, strStoreID)
strAddress = objCDOMsg.Sender.Address

'Add to recordset
If txtemail = strAddress Then
With TempRst
.AddNew
!DAID = Me!DAID
!DAContactDate = objCDOMsg.TimeReceived
!DAContactMode = "Email"
!DAContactInit = "Individual"
!DAContactDetails = itm.Body
!DAInboxEntryID = objCDOMsg.EntryID
.Update
End With

On Error Resume Next

'Each time a record is added, refresh subform to reflect that
Forms!frmDirectAccessions!frmDirectAccessionsSubform.Requery

Else
End If

Next itm

'Reset CDO session variables to nothing
Set objCDOMsg = Nothing
objSession.Logoff
Set objSession = Nothing

ErrorHandlerExit:
Exit Sub

ErrorHandler:
If Err.Number = 429 Then
If appword Is Nothing Then
Set appword = CreateObject("word.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If
End Sub

 

[Sue Mosher [MVP-Outlook]]

Your Outlook version is a key factor, but you forgot to mention it. That said, Redemption would give you an order of magnitude more speed and avoid security prompts.

If you want to stick with Outlook and see how to filter for a time period, see http://www.outlookcode.com/d/propsyntx.htm
--
Sue Mosher, Outlook MVP
Author of Configuring Microsoft Outlook 2003

and Microsoft Outlook Programming - Jumpstart for
Administrators, Power Users, and Developers