Access VBA邮件导入代码四项修改需求技术咨询

以下是针对四项需求修改后的完整VBA代码，附带各修改点的详细说明：

Option Explicit ' 强制变量声明，避免隐性错误

Sub ImportMailPropFromOutlook()
    ' Set up Outlook objects.
    Dim ol As New Outlook.Application
    Dim olns As Outlook.Namespace
    Dim ofO As Outlook.MAPIFolder
    Dim sharedRecipient As Outlook.Recipient
    Dim objItems As Outlook.Items
    Dim startDate As Date, endDate As Date

    Set olns = ol.GetNamespace("MAPI")
    ' 修改1：获取团队邮箱收件箱
    Set sharedRecipient = olns.CreateRecipient("team-mailbox@yourdomain.com") ' 替换为实际团队邮箱地址
    sharedRecipient.Resolve
    If sharedRecipient.Resolved Then
        Set ofO = olns.GetSharedDefaultFolder(sharedRecipient, olFolderInbox)
    Else
        MsgBox "无法找到指定的团队邮箱，请检查地址是否正确。"
        Exit Sub
    End If

    ' 修改3：添加日期范围筛选
    On Error Resume Next
    startDate = InputBox("请输入开始日期（格式：YYYY/MM/DD）", "日期筛选", Date - 7)
    If Err.Number <> 0 Then
        MsgBox "开始日期格式错误，程序退出。"
        Exit Sub
    End If
    endDate = InputBox("请输入结束日期（格式：YYYY/MM/DD）", "日期筛选", Date)
    If Err.Number <> 0 Then
        MsgBox "结束日期格式错误，程序退出。"
        Exit Sub
    End If
    On Error GoTo 0

    ' 应用日期筛选（结束日期+1确保包含当天所有邮件）
    Set objItems = ofO.Items.Restrict("[ReceivedTime] >= '" & Format(startDate, "ddddd hh:mm AMPM") & "' AND [ReceivedTime] <= '" & Format(endDate + 1, "ddddd hh:mm AMPM") & "'")
    objItems.Sort "[ReceivedTime]", olAscending ' 按收件时间排序

    ' 调用邮件属性导入逻辑
    GetMailProp objItems, ofO

    MsgBox "邮件导入完成，符合条件的邮件已移动至Imported文件夹。"
End Sub

Sub GetMailProp(objProp As Outlook.Items, ofProp As Outlook.MAPIFolder)
    ' Set up DAO objects (依赖现有Access "Email"表)
    Dim rst As DAO.Recordset
    Set rst = CurrentDb.OpenRecordset("Email")

    ' Set Up Outlook objects
    Dim cMail As Outlook.MailItem
    Dim cAtch As Outlook.Attachments
    Dim importedFolder As Outlook.MAPIFolder
    Dim iNumMessages As Integer, i As Integer, j As Integer
    Dim strAtch As String, cntAtch As Integer
    Dim senderSMTP As String

    ' 修改4：获取或创建Imported文件夹
    On Error Resume Next
    Set importedFolder = ofProp.Folders("Imported")
    If Err.Number <> 0 Then
        Set importedFolder = ofProp.Folders.Add("Imported")
    End If
    On Error GoTo 0

    ' 遍历邮件并写入Access表
    iNumMessages = objProp.Count
    If iNumMessages <> 0 Then
        For i = 1 To iNumMessages
            If TypeName(objProp(i)) = "MailItem" Then
                Set cMail = objProp(i)
                ' 检查是否已导入（避免重复记录）
                rst.Find "[EntryID] = '" & cMail.EntryID & "'"
                If rst.NoMatch Then
                    rst.AddNew
                    rst!EntryID = cMail.EntryID
                    rst!ConversationID = cMail.ConversationID
                    ' 修改2：获取发件人SMTP地址
                    senderSMTP = GetSMTPAddressFromMailItem(cMail)
                    rst!SenderName = cMail.SenderName
                    rst!SenderEmail = senderSMTP ' 需确保Email表已添加SenderEmail文本字段
                    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
                        strAtch = ""
                        For j = 1 To cntAtch
                            strAtch = strAtch & cAtch.Item(j).FileName & "; "
                        Next
                        rst!Attachments = Left(strAtch, Len(strAtch) - 2) ' 移除末尾多余的分号和空格
                    Else
                        rst!Attachments = "No Attachments"
                    End If
                    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.Update

                    ' 修改4：移动邮件至Imported文件夹
                    cMail.Move importedFolder
                End If
            End If
        Next i
    End If
    rst.Close
    Set rst = Nothing
End Sub

' 辅助函数：获取发件人SMTP邮箱地址
Function GetSMTPAddressFromMailItem(mail As Outlook.MailItem) As String
    Dim sender As Outlook.AddressEntry
    Dim exchangeUser As Outlook.ExchangeUser

    Set sender = mail.Sender
    ' 处理Exchange用户的情况
    If sender.AddressEntryUserType = olExchangeUserAddressEntry Or sender.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
        Set exchangeUser = sender.GetExchangeUser
        If Not exchangeUser Is Nothing Then
            GetSMTPAddressFromMailItem = exchangeUser.PrimarySmtpAddress
        Else
            GetSMTPAddressFromMailItem = mail.SenderEmailAddress
        End If
    Else
        ' 非Exchange用户直接返回邮箱地址
        GetSMTPAddressFromMailItem = mail.SenderEmailAddress
    End If
End Function

各修改点说明 #

1. 切换至团队邮箱读取 #

• 替换原代码中GetDefaultFolder(olFolderInbox)的个人收件箱逻辑，改用CreateRecipient指定团队邮箱地址，通过GetSharedDefaultFolder获取共享收件箱。
• 增加地址解析校验，避免因邮箱地址错误导致程序崩溃。

2. 获取发件人SMTP邮箱地址 #

• 新增GetSMTPAddressFromMailItem辅助函数，兼容两种场景：
  • 发件人为Exchange域用户时，解析其官方SMTP地址；
  • 外部发件人直接返回原始邮箱地址。
• 需确保Access的Email表已添加SenderEmail文本字段，用于存储SMTP地址。

3. 添加日期范围筛选 #

• 通过输入框让用户自定义导入的日期范围，默认范围为最近7天至当天。
• 使用Items.Restrict方法过滤邮件，仅处理指定时间范围内的邮件，大幅提升导入效率。
• 增加日期格式错误捕获，避免无效输入导致程序异常。

4. 导入后移动邮件至'Imported'文件夹 #

• 在导入逻辑开始前，自动检查并创建Imported文件夹（若不存在）。
• 邮件成功写入Access表后，立即移动至目标文件夹，避免重复导入。
• 新增重复导入校验：通过EntryID判断邮件是否已导入，防止生成重复记录。

内容的提问来源于stack exchange，提问作者Classre