Outlook自定义按钮：按规则将收发邮件保存至指定项目目录

核心实现逻辑 #

通过Outlook VBA编写宏实现邮件的规则化保存，再将宏绑定到自定义按钮上，满足以下需求：

• 收件邮件保存至格式为yyyymmdd - {sender's initials} - {email subject}的文件夹
• 发件邮件保存至格式为yyyymmdd - {email subject}的文件夹
• 支持用户输入自定义项目路径（示例：C:\Users\User.Name\{project_name_input}）

具体实现步骤 #

1. 打开Outlook VBA编辑器 #

按Alt + F11打开Outlook的VBA编辑器，在左侧Project窗口中，右键点击ThisOutlookSession，选择查看代码。

2. 粘贴VBA代码 #

Sub SaveMailToProjectFolder()
    Dim objMail As MailItem
    Dim savePath As String
    Dim folderName As String
    Dim fullFolderPath As String
    Dim currentDate As String
    Dim senderInitials As String
    
    ' 获取选中的邮件
    Set objMail = Application.ActiveExplorer.Selection.Item(1)
    
    ' 让用户输入项目路径
    savePath = InputBox("请输入项目根路径（示例：C:\Users\User.Name\ProjectA）", "项目路径输入")
    If savePath = "" Then Exit Sub ' 用户取消输入则退出
    
    ' 格式化当前日期为yyyymmdd
    currentDate = Format(Date, "yyyymmdd")
    
    ' 判断是收件还是发件邮件，生成对应文件夹名
    If objMail.SenderEmailType = "EX" Then
        ' 内部邮件，获取发件人姓名首字母
        senderInitials = Left(objMail.SenderName, 1) & Right(Left(objMail.SenderName, InStr(objMail.SenderName, " ") + 1), 1)
    Else
        ' 外部邮件，获取发件人邮箱前缀首字母
        senderInitials = Left(Split(objMail.SenderEmailAddress, "@")(0), 1)
    End If
    
    Select Case objMail.MessageClass
        Case "IPM.Note" ' 收件邮件
            folderName = currentDate & " - " & senderInitials & " - " & CleanFileName(objMail.Subject)
        Case "IPM.Note.Sent" ' 发件邮件
            folderName = currentDate & " - " & CleanFileName(objMail.Subject)
        Case Else
            MsgBox "仅支持收件/发件邮件的保存"
            Exit Sub
    End Select
    
    ' 拼接完整文件夹路径
    fullFolderPath = savePath & "\" & folderName
    
    ' 创建文件夹（如果不存在）
    If Dir(fullFolderPath, vbDirectory) = "" Then
        MkDir fullFolderPath
    End If
    
    ' 保存邮件为.msg格式到目标文件夹
    objMail.SaveAs fullFolderPath & "\" & CleanFileName(objMail.Subject) & ".msg", olMSG
    
    MsgBox "邮件已成功保存至：" & fullFolderPath, vbInformation
End Sub

' 辅助函数：清理文件名中的非法字符
Function CleanFileName(strFileName As String) As String
    Dim illegalChars As Variant
    Dim char As Variant
    
    illegalChars = Array("/", "\", ":", "*", "?", """", "<", ">", "|")
    For Each char In illegalChars
        strFileName = Replace(strFileName, char, "")
    Next char
    
    CleanFileName = strFileName
End Function

3. 添加自定义按钮到工具栏 #

1. 打开Outlook，点击顶部文件选项卡，选择选项 -> 自定义功能区
2. 在右侧主选项卡列表中，勾选开发工具，点击确定
3. 切换到开发工具选项卡，点击宏，选择SaveMailToProjectFolder宏，点击添加到快速访问工具栏
4. （可选）右键点击快速访问工具栏上的宏按钮，选择修改按钮，设置自定义图标和名称

4. 测试功能 #

1. 在Outlook中选中一封收件或发件邮件
2. 点击快速访问工具栏上的自定义按钮
3. 在弹出的输入框中填写项目根路径，点击确定
4. 检查目标路径下是否生成了符合规则的文件夹，并成功保存了邮件

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