VBA in Access 2010 to import emails located in Outlook Public (Sub)Folders - Including Folder Name & Attachments?

Question

I am trying to develop an Access database for keeping track of emails in Outlook. I was able to develop the following code by combining bits and pieces from many internet searches. The attached code finally works and took me more time than I want to admit to develop. I am new to VBA programming and am trying to grunt my way through the process. Anyway, out of frustration and dread that this project could end up taking way longer than I wanted it to, I thought I would finally ask for some help. The following are features, in order of priority, that I would eventually like to add to the below code:

High Priority:

(1) Need recursive VBA code to import emails located in all subfolders. (2) Need VBA code to insert the Folder name where the email is located into Access Database. Folder Path is not necessary. (3) Need VBA code to insert the file name of any user attached documents.

Low Priority (Access can be used to remove duplicates until issue is resolved):

(4) Want VBA code to append data with new emails when macro is run.

Nice future options:

(5) VBA code to allow me to pick a folder. Option would allow for future flexibility.

I am running Access and Outlook 2010 on Window 7 (64 Bit Computer). The following is my code so far:

Sub ImportContactsFromOutlook()

   ' This code is based in Microsoft Access.

   ' Set up DAO objects (uses existing "tblContacts" table)
   Dim rst As DAO.Recordset
   Set rst = CurrentDb.OpenRecordset("Email")


   ' Set up Outlook objects.
   Dim ol As New Outlook.Application
   Dim olns As Outlook.NameSpace
   Dim cf As Outlook.MAPIFolder
   Dim c As Outlook.MailItem
   Dim objItems As Outlook.Items
   Dim Prop As Outlook.UserProperty

   Set olns = ol.GetNamespace("MAPI")
   '--- (5) --- VBA code to allow me to pick a folder. Option would allow for future     flexability.
   Set cf = olns.GetDefaultFolder(olPublicFoldersAllPublicFolders)
   '--- (1) --- Need recursive VBA code to import emails located in all subfolders.
   Set objItems = cf.Items
   iNumMessages = objItems.Count
   If iNumMessages <> 0 Then
      For i = 1 To iNumMessages
         If TypeName(objItems(i)) = "MailItem" Then
            Set c = objItems(i)
            rst.AddNew
            rst!EntryID = c.EntryID
            rst!ConversationID = c.ConversationID
            rst!Sender = c.Sender
            rst!SenderName = c.SenderName
            rst!SentOn = c.SentOn
            rst!To = c.To
            rst!CC = c.CC
            rst!BCC = c.BCC
            rst!Subject = c.Subject
            rst!Attachments = c.Attachments.Count
            '--- (3) --- Need VBA code to insert the file name of any user attached     documents. ".Count" is used to avoid error and can be replaced.
            rst!Body = c.Body
            rst!HTMLBody = c.HTMLBody
            rst!Importance = c.Importance
            rst!Size = c.Size
            rst!CreationTime = c.CreationTime
            rst!ReceivedTime = c.ReceivedTime
            rst!ExpiryTime = c.ExpiryTime
            '--- (2) --- Need VBA code to insert the Folder name where the email is     located into Access Database. Folder Path is not necessary.
            rst.Update
         End If
      Next i
      rst.Close
      MsgBox "Finished."
   Else
      MsgBox "No e-mails to export."
   End If
   '--- (4) --- Want VBA code to append data with new emails when macro is run.

End Sub

Here are some helpful reference material I tried to use. Some of them have what looked like fancy tools. Because I am learning I either could not implement or did not understand some of them..

• msdn.microsoft.com/en-us/library/ee861519(v=office.14).aspx
• msdn.microsoft.com/en-us/library/office/ee861520(v=office.14).aspx
• accessexperts.net/blog/2011/07/07/importing-outlook-emails-into-access/
• add-in-express.com/creating-addins-blog/2011/08/15/how-to-get-list-of-attachments/
• databasejournal.com/features/msaccess/article.php/3827996/Working-With-Outlook-from-Access.htm
• stackoverflow.com/questions/7298591/copying-all-incoming-emails-in-outlook-inbox-and-personal-subfolders-to-excel-th

Any recommendations or direction is welcome. Thanks for the help. It is appreciated.

---

Here is my code as it stands now (see below). There are still a few problems when I run it. On the first time the code is run, since there are no records in the Access database table, I receive the following error:

Run-time error '3021': No current record.

Is there an error check or way I can code around this? Also, after the Access database is populated, the following code only excludes those emails found in the primary folder, not the sub folder:

If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <> cMail.EntryID) Then

I am trying to figure out why. Last, I still need to know how pull a list of user attached documents into the access database. The following code pulls all attachments, including the embedded ones, and only returns the first attachment in the document:

                    Set cAtch = cMail.Attachments
                    cntAtch = cAtch.Count
                    If cntAtch > 0 Then
                        For j = cntAtch To 1 Step -1
                            strAtch = cAtch.Item(j).FileName
                            rst!Attachments = strAtch
                        Next
                    Else
                        rst!Attachments = "No Attachments"
                    End If

Again, any help would be appreciated. Thanks.

Sub ImportMailPropFromOutlook()

    ' Code for specifing top level folder and initializing routine.

    ' Set up Outlook objects.
    Dim ol As New Outlook.Application
    Dim olns As Outlook.NameSpace
    Dim ofO As Outlook.MAPIFolder
    Dim ofSubO As Outlook.MAPIFolder
    Dim objItems As Outlook.Items

    Set olns = ol.GetNamespace("MAPI")
    Set ofO = olns.GetDefaultFolder(olFolderInbox) '--- Specifies top level folder for     importing Oultook mail.
    'Set of = olns.PickFolder '--- Allows user to select top level folder for importing     Outlook mail.

    'Set info and call GetMailProp code.
    Set objItems = ofO.Items
    GetMailProp objItems, ofO

    'Set info and call ProcessSubFolders.
    For Each ofSubO In of.Folders
        Set objItems = ofSubO.Items
        ProcessSubFolders objItems, ofSubO
    Next

End Sub

Sub GetMailProp(objProp As Outlook.Items, ofProp As Outlook.MAPIFolder)

    ' Code for writeing Outlook mail properties to Access.

    ' Set up DAO objects (uses existing Access "Email" table).
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Email")

    'Set Up Outlook objects.
    Dim cMail As Outlook.MailItem
    Dim cAtch As Outlook.Attachments

    'Write Outlook mail properties to Access "Email" table.
    iNumMessages = objProp.Count
    If iNumMessages <> 0 Then
        For i = 1 To iNumMessages
            If TypeName(objProp(i)) = "MailItem" Then
                Set cMail = objProp(i)
                If ([rst]![EmailLocation] <> ofProp.Name) And ([rst]![EntryID] <>     cMail.EntryID) Then
                    rst.AddNew
                    rst!EntryID = cMail.EntryID
                    rst!ConversationID = cMail.ConversationID
                    rst!Sender = cMail.Sender
                    rst!SenderName = cMail.SenderName
                    rst!SentOn = cMail.SentOn
                    rst!To = cMail.To
                    rst!CC = cMail.CC
                    rst!BCC = cMail.BCC
                    rst!Subject = cMail.Subject
                    Set cAtch = cMail.Attachments
                    cntAtch = cAtch.Count
                    If cntAtch > 0 Then
                        For j = cntAtch To 1 Step -1
                            strAtch = cAtch.Item(j).FileName
                            rst!Attachments = strAtch
                        Next
                    Else
                        rst!Attachments = "No Attachments"
                    End If
                    rst!Count = cMail.Attachments.Count
                    rst!Body = cMail.Body
                    rst!HTMLBody = cMail.HTMLBody
                    rst!Importance = cMail.Importance
                    rst!Size = cMail.Size
                    rst!CreationTime = cMail.CreationTime
                    rst!ReceivedTime = cMail.ReceivedTime
                    rst!ExpiryTime = cMail.ExpiryTime
                    rst!EmailLocation = ofProp.Name
                    rst.Update
                End If
            End If
        Next i
    End If

End Sub

Sub ProcessSubFolders(objItemsR As Outlook.Items, OfR As Outlook.MAPIFolder)

    'Code for processing subfolders

    ' Set up Outlook objects.
    Dim ofSubR As Outlook.MAPIFolder

    'Set info and call GetMailProp code.
    GetMailProp objItemsR, OfR

    'Set info and call ProcessSubFolders. Recursive.
    For Each ofSubR In OfR.Folders
        Set objItemsR = ofSubR.Items
        ProcessSubFolders objItemsR, ofSubR
    Next

End Sub

---

I had an opportunity to work on the code some more. What I am trying to do is import emails located within all the sub-folders of my Outlook account into Access. The VBA code is in Access. I only need certain mail item properties. Mostly the ones you would need to replicate the print memo function in Outlook.

I added a few more that I thought I would need to help exclude duplicates located in the same folder. The are duplicate emails in different public sub-folders but I need to know that in my database record.

I still need a recursive sub or function to make sure I get all the sub-folders. I tried a For/Next loop but this only searches one level of sub-folders. I could defiantly use some help on this. This seems like the tough part.

My updated code is:

Sub ImportContactsFromOutlook()

   ' This code is based in Microsoft Access.

   ' Set up DAO objects (uses existing "Email" table)
   Dim rst As DAO.Recordset
   Set rst = CurrentDb.OpenRecordset("Email")


   ' Set up Outlook objects.
   Dim ol As New Outlook.Application
   Dim olns As Outlook.NameSpace
   Dim cf As Outlook.MAPIFolder
   Dim cMail As Outlook.MailItem
   Dim cAtch As Outlook.Attachments
   Dim objItems As Outlook.Items
   Dim of As Outlook.Folder
   Dim ofSub As Outlook.Folder

   Set olns = ol.GetNamespace("MAPI")
   '--- (5) ---
   'Would eventually be nice to allow a user to select a folder. Folderpicker? Lowest     priority.

   Set of = olns.GetDefaultFolder(olFolderInbox)
   '--- (1) ---
   'Loop only searches one level down. I will need all subfolders. Most examples I saw     call external Sub? Recursive?
   For Each ofSub In of.Folders
   Set objItems = ofSub.Items
   iNumMessages = objItems.Count
   If iNumMessages <> 0 Then
      For i = 1 To iNumMessages
         If TypeName(objItems(i)) = "MailItem" Then
            Set cMail = objItems(i)
            rst.AddNew
            rst!EntryID = cMail.EntryID
            rst!ConversationID = cMail.ConversationID
            rst!Sender = cMail.Sender
            rst!SenderName = cMail.SenderName
            rst!SentOn = cMail.SentOn
            rst!To = cMail.To
            rst!CC = cMail.CC
            rst!BCC = cMail.BCC
            rst!Subject = cMail.Subject
            '--- (3) ---
            'Code only inserts first attachment. Code Also inserts embedded     attachments.
            'Need code to insert all user selected attachments (ex. PDF Document) and     no embedded attachments.
            Set cAtch = cMail.Attachments
            cntAtch = cAtch.Count
                If cntAtch > 0 Then
                    For j = cntAtch To 1 Step -1
                    strAtch = cAtch.Item(j).FileName
                    rst!Attachments = strAtch
                    Next
                Else
                    rst!Attachments = "No Attachments"
                End If
            rst!Count = cMail.Attachments.Count
            rst!Body = cMail.Body
            rst!HTMLBody = cMail.HTMLBody
            rst!Importance = cMail.Importance
            rst!Size = cMail.Size
            rst!CreationTime = cMail.CreationTime
            rst!ReceivedTime = cMail.ReceivedTime
            rst!ExpiryTime = cMail.ExpiryTime
            '--- (2) ---
            ' Solved - Figured out how to call folder location into databse.
            rst!EmailLocation = ofSub.Name
            rst.Update
         End If
      Next i
   End If
   Next
   '--- (4) ---
   'Still need code to append Access database with only new records.
   'Duplicate email can exist in differenc subfolders but not same subfolder.
End Sub

Any help would be appreciated.

Answer 1

I was able to find some examples on the web to resolve the exclude duplicate mail records and Run-time error '3021' with the following code:

' If code checks outlook mail for and excludes duplicate records based on table fields [EntryID] and [EmailLocation].
If Cnt = DCount("[EntryID] & [EmailLocation]", "Email", "[EntryID] = """ & cMail.EntryID & """ And [EmailLocation] = """ & ofProp.Name & """") = 0 Then
    'Code used to insert individual outlook mail properties.
End If

Still need to resolve the issue with attachments. Any help would be appreciated. Thank you.

Answer 2

Check this example for selecting the Outlook contact, from code written by Helen Feddema. "Exporting Calendar Items to Excel" http://www.helenfeddema.com/Code%20Samples.htm