Access 2010 中的 VBA 可导入位于 Outlook 公共（子）文件夹中的电子邮件 - 包括文件夹名称和附件？

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

提问by user2052979

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:

我正在尝试开发一个 Access 数据库来跟踪 Outlook 中的电子邮件。我能够通过结合来自许多互联网搜索的点点滴滴来开发以下代码。附加的代码终于可以工作了，我花了比我想承认的更多的时间来开发。我是 VBA 编程的新手，我正在努力完成整个过程。无论如何，出于沮丧和害怕这个项目最终可能会比我想要的时间更长，我想我最终会寻求一些帮助。以下是按优先级排序的功能，我最终希望将其添加到以下代码中：

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.

(1) 需要递归 VBA 代码才能导入位于所有子文件夹中的电子邮件。(2) 需要 VBA 代码将电子邮件所在的文件夹名称插入 Access 数据库。文件夹路径不是必需的。(3) 需要VBA代码插入任何用户附加文件的文件名。

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.

(4) 希望 VBA 代码在运行宏时将数据附加到新电子邮件中。

Nice future options:

不错的未来选择：

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

(5) 允许我选择文件夹的 VBA 代码。选项将允许未来的灵活性。

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

我在 Window 7（64 位计算机）上运行 Access 和 Outlook 2010。以下是我到目前为止的代码：

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

• 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:

这是我现在的代码（见下文）。当我运行它时仍然存在一些问题。在第一次运行代码时，由于 Access 数据库表中没有记录，我收到以下错误：

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

运行时错误“3021”：没有当前记录。

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:

是否有错误检查或方法可以解决这个问题？此外，在填充 Access 数据库后，以下代码仅排除在主文件夹中找到的那些电子邮件，而不是子文件夹：

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.

我有机会更多地处理代码。我想要做的是将位于我的 Outlook 帐户的所有子文件夹中的电子邮件导入 Access。VBA 代码在 Access 中。我只需要某些邮件项目属性。大多数情况下，您需要在 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.

我仍然需要一个递归子或函数来确保我得到所有的子文件夹。我尝试了 For/Next 循环，但这仅搜索一级子文件夹。我可以大胆地使用一些帮助。这似乎是困难的部分。

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.

任何帮助，将不胜感激。

回答by user2052979

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:

我能够在网上找到一些示例来解决排除重复邮件记录和运行时错误“3021”的问题，代码如下：

' 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.

仍然需要解决附件问题。任何帮助，将不胜感激。谢谢你。

回答by Kostas Anagnostakis

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

检查此示例以从 Helen Feddema 编写的代码中选择 Outlook 联系人。“将日历项目导出到 Excel” http://www.helenfeddema.com/Code%20Samples.htm