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.
