如何实现Outlook收发邮件自动存硬盘？两段收件代码无法共存

你遇到的这个问题其实很常见——两段代码之所以不能同时生效，核心原因是它们的逻辑冲突了。我来帮你拆解问题并给出整合后的解决方案：

问题根源 #

你手里的两段代码都定义了Private WithEvents Items As Outlook.Items，而且在Application_Startup里都把Items指向了收件箱的邮件集合。当两段代码共存时，后执行的初始化会覆盖前一个的变量指向，再加上两个同名的Items_ItemAdd事件过程互相冲突，最终就只能有一段代码正常工作。

解决方案：整合收发邮件的监听逻辑 #

我们可以把收件箱和发件箱的监听分开，用不同的变量名区分两个邮件集合，再分别处理它们的新邮件事件，这样就能同时自动保存收件和发件的邮件了。

把下面这段完整代码替换你原来的两段代码，放到Outlook的ThisOutlookSession模块里即可：

Option Explicit

' 分别定义收件箱、发件箱的监听变量，避免重名冲突
Private WithEvents InboxItems As Outlook.Items
Private WithEvents SentItems As Outlook.Items

Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Set Ns = Application.GetNamespace("MAPI")
    
    ' 初始化收件箱监听
    Set InboxItems = Ns.GetDefaultFolder(olFolderInbox).Items
    ' 初始化发件箱监听
    Set SentItems = Ns.GetDefaultFolder(olFolderSentMail).Items
End Sub

' 处理收件箱新邮件
Private Sub InboxItems_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        SaveTargetMail Item, "收件箱邮件"
    End If
End Sub

' 处理发件箱新邮件
Private Sub SentItems_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
        SaveTargetMail Item, "已发送邮件"
    End If
End Sub

' 通用保存函数，减少重复代码
Private Sub SaveTargetMail(Item As Outlook.MailItem, folderTag As String)
    Dim sPath As String
    Dim dtDate As Date
    Dim sName As String
    Dim enviro As String
    
    ' 获取系统文档路径，可自行修改保存位置
    enviro = CStr(Environ("USERPROFILE"))
    sPath = enviro & "\Documents\Outlook自动备份\" & folderTag & "\"
    
    ' 自动创建不存在的文件夹
    If Dir(sPath, vbDirectory) = "" Then
        MkDir sPath
    End If
    
    ' 处理邮件名称，避免非法字符
    dtDate = IIf(folderTag = "已发送邮件", Item.SentOn, Item.ReceivedTime)
    sName = Format(dtDate, "yyyy-mm-dd hh-mm-ss") & " - " & Item.Subject
    
    ' 替换Windows文件名不允许的字符
    sName = Replace(sName, "/", "-")
    sName = Replace(sName, "\", "-")
    sName = Replace(sName, ":", "-")
    sName = Replace(sName, "*", "-")
    sName = Replace(sName, "?", "-")
    sName = Replace(sName, """", "-")
    sName = Replace(sName, "<", "-")
    sName = Replace(sName, ">", "-")
    sName = Replace(sName, "|", "-")
    
    ' 保存为MSG格式，如需EML可将olMSG改为olEML
    Item.SaveAs sPath & sName & ".msg", olMSG
End Sub

代码使用说明 #

1. 按Alt+F11打开Outlook的VBA编辑器，找到左侧的ThisOutlookSession模块，把代码粘贴进去
2. 确保Outlook启用了宏（路径：文件→选项→信任中心→信任中心设置→宏设置，根据安全需求选择启用方式）
3. 重启Outlook后，代码会在启动时自动初始化监听，之后新收到或发出的邮件都会自动保存到指定路径

内容的提问来源于stack exchange，提问作者Proximus Seraphim Dimitri Davi