ProgrammingMSAccess.com

The ProgrammingMSAccess.COM Site

A vba Procedure that demonstrates how to navigate folders, add contacts, count and print contact information, and trap error in outlook from an access.  this procedure runs in a vba project from access, but it requires a reference to the outlook object model library.  you must also previous create trdemo as a first-level outlook folder and trcontacts as a nested folder within it.

Sub MyTRContacts()
On Error GoTo MyTRContactsTrap
Dim ola1 As Outlook.Application
Dim nsp1 As Outlook.NameSpace
Dim folc1 As Outlook.Folders
Dim fol1 As Outlook.MAPIFolder
Dim cit1 As Outlook.ContactItem
Dim citc1 As Outlook.Items

'Set reference to Outlook, Namespace object,
'and the first-level folders collection
Set ola1 = CreateObject("Outlook.Application")
Set nsp1 = ola1.GetNamespace("MAPI")
Set folc1 = nsp1.Folders.Item(1).Folders

'Set a reference to the TRContacts folder
'and add two Contactitem objects to it
Set fol1 = folc1.Item("TRDemo").Folders.Item("TRContacts")
Set cit1 = fol1.Items.Add(olContactItem)
With cit1
    .FirstName = "Rick"
    .LastName = "Dobson"
    .Email1Address = "rickd@cabinc.net"
    .Save
End With
Set cit1 = fol1.Items.Add(olContactItem)
With cit1
    .FirstName = "Virginia"
    .LastName = "Dobson"
    .Email1Address = "virginiad@cabinc.net"
    .Save
End With

'Point to specific contacts and print
'their first email address property
Debug.Print fol1.Items.Count
Debug.Print fol1.Items.Item(1).Email1Address
Debug.Print fol1.Items.Item("Virginia Dobson").Email1Address

'Enumerate all contact items and print
'their first and last names as well as
'their first email address property
Set citc1 = fol1.Items
For Each cit1 In citc1
    Debug.Print cit1.FirstName, cit1.LastName, _
    cit1.Email1Address
Next

'Find and print all contacts with a LastName
'of Dobson; generate an error after no more
'contacts exist with a LastName of Dobson
Set cit1 = citc1.Find("[LastName] = 'Dobson'")
IsItThere:
Debug.Print cit1.FirstName, cit1.LastName, _
cit1.Email1Address
Set cit1 = citc1.FindNext
GoTo IsItThere

MyTRContactsExit:
Exit Sub

MyTRContactsTrap:
If Err.Number = 91 Then
'Error because object does not exist
    Debug.Print "Reached end of Find match list."
Else
    Debug.Print Err.Number, Err.Description
End If
Resume MyTRContactsExit

End Sub

Want to understand  Microsoft Access 2000/2002/2003 so that you can program it to do more tasks like this?  Get Programming Microsoft Office Access 2003 by Rick Dobson from Microsoft Press.  Learn more about the book by clicking here.

Copyright 2003 CAB, Inc. All rights reserved. Republication or redistribution of CAB, Inc. content, including by framing or similar means, is expressly prohibited without the prior written consent of CAB, Inc. CAB, Inc. shall not be liable for any errors in the content, or for any actions taken in reliance thereon.