MS Access: Inserting and Deleting Contact Items With VBA

Here’s some code that is the start of a library to work with Outlook’s folders. It’s based on some code samples from the web, refactored into something resembling a library.

The best feature is the function OLGetSubFolder, which returns a MAPI folder object for a given path. Totally useful.

I don’t really understand why the first folder is under folders.Item(1), but the sample code used that, so I’m calling that the root folder. Maybe there are folders above that, and this is wrong.

Also featured in this code are a function to test for the existence of an object, and create folders.

[vb]
Option Compare Database

Public Sub test()
    Dim foldroot As Outlook.MAPIFolder
    Dim foldr As Outlook.MAPIFolder
    Dim newfolder As Outlook.MAPIFolder

    Set foldroot = OLGetRootUserFolder()
    Set foldr = OLGetSubFolder(foldroot, "\Contacts")
    
    Set foldr = OLMakeFolder(foldr, "Lists")
    Set newfolder = OLMakeFolder(foldr, "Executive Board")
    Set newfolder = OLMakeFolder(foldr, "Delegates")
    Set newfolder = OLMakeFolder(foldr, "COPE Board")
    OLExportQueryToFolder newfolder, "prmCOPEBOARD"
    Set newfolder = OLMakeFolder(foldr, "Affiliates Offices")
End Sub

Public Sub OLExportQueryToFolder(folder As Outlook.MAPIFolder, query As String)
    Dim sFname, sLname, sEmail As String
    Dim dbs As Database
    Dim rst As Recordset
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(query, dbOpenForwardOnly)
    While Not rst.EOF
        If IsNull(rst!Fname) Then sFname = "" Else sFname = rst!Fname
        If IsNull(rst!Lname) Then sLname = "" Else sLname = rst!Lname
        If IsNull(rst!email) Then sEmail = "" Else sEmail = rst!email
        OLInsertContactItem folder, sFname, sLname, sEmail
        rst.MoveNext
    Wend
End Sub


Public Function OLMakeFolder(foldr As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder
    Dim f As Outlook.MAPIFolder
On Error GoTo FolderDoesNotExist
FolderExists:
    Set f = foldr.folders(newfolder)
    Set OLMakeFolder = f
    Exit Function
FolderDoesNotExist:
    Set f = foldr.folders.Add(newfolder)
    Set OLMakeFolder = f
End Function

' based on <a title="http://www.programmingmsaccess.com/Samples/VBAProcs/VBAProcsToManageOutlookContactsFromAccess.htm" href="http://www.programmingmsaccess.com/Samples/VBAProcs/VBAProcsToManageOutlookContactsFromAccess.htm">http://www.programmingmsaccess.c...</a>
Public Sub OLInsertContactItem(foldr As Outlook.MAPIFolder, ByVal first As String, ByVal last As String, ByVal email As String)
    Dim cit1 As Outlook.ContactItem
    Dim citc1 As Outlook.Items
        
    Set cit1 = foldr.Items.Add(olContactItem)
    With cit1
        .FirstName = first
        .LastName = last
        .Email1Address = email
        .Save
    End With
End Sub

Private Sub OLDeleteAllInFolder(MAPIFolder As Outlook.MAPIFolder)
    Dim c As Object
    Dim i As Outlook.Items
    Set i = MAPIFolder.Items
    For Each c In i
        c.Delete
    Next
End Sub

' based on <a title="http://msdn2.microsoft.com/en-us/library/bb756875.aspx" href="http://msdn2.microsoft.com/en-us/library/bb756875.aspx">http://msdn2.microsoft.com/en-us...</a>
Private Function OLGetSubFolder(MAPIFolderRoot As Outlook.MAPIFolder, folderPath As String) As Outlook.MAPIFolder
    Dim returnFolder As Object
    Dim parts() As String
    Dim part
    
    Set returnFolder = MAPIFolderRoot
    parts = Split(folderPath, "")
    
    For Each part In parts
        ' Debug.Print "-" & part & "-"
        If part <> "" Then
            Set returnFolder = returnFolder.folders.Item(part)
        End If
    Next

    Set OLGetSubFolder = returnFolder
End Function

Private Function OLGetRootUserFolder() As Outlook.MAPIFolder
    Dim ola1 As Outlook.Application
    Dim foldr As Outlook.MAPIFolder
    Set ola1 = CreateObject("Outlook.Application")
    Set OLGetRootUserFolder = ola1.GetNamespace("MAPI").folders.Item(1)
End Function
[/vb]