我之前也碰到过一模一样的需求，刚好可以帮你调整原有的宏代码，实现每封带附件的邮件单独生成「日期_邮件标题」的文件夹，同时把附件和邮件本身都存进去。下面是修改后的完整代码和关键说明：

Sub SaveAttachmentsPerEmail()
    Dim objOutlook As Outlook.Application
    Dim objNamespace As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim objAttachment As Outlook.Attachment
    Dim saveRootPath As String
    Dim mailFolderName As String
    Dim savePath As String
    
    ' 设置附件保存的根路径，请自行修改为你的目标路径
    saveRootPath = "C:\Your\Save\Path\"
    
    ' 获取Outlook命名空间和指定文件夹（这里默认是收件箱，可修改为其他文件夹）
    Set objOutlook = CreateObject("Outlook.Application")
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox) ' 可替换为其他文件夹，比如objNamespace.Folders("你的邮箱").Folders("指定文件夹")
    
    ' 标记是否找到带附件的邮件
    Dim hasAttachmentEmails As Boolean
    hasAttachmentEmails = False
    
    ' 遍历文件夹中的每一封邮件
    For Each objItem In objFolder.Items
        ' 只处理邮件项，跳过会议邀请等其他类型
        If TypeName(objItem) = "MailItem" Then
            ' 检查邮件是否有附件
            If objItem.Attachments.Count > 0 Then
                hasAttachmentEmails = True
                
                ' 生成文件夹名称：日期_邮件标题，处理非法字符
                mailFolderName = Format(objItem.ReceivedTime, "yyyy-mm-dd") & "_" & ReplaceIllegalChars(objItem.Subject)
                savePath = saveRootPath & mailFolderName & "\"
                
                ' 如果文件夹不存在则创建
                If Dir(savePath, vbDirectory) = "" Then
                    MkDir savePath
                End If
                
                ' 保存所有附件到该文件夹
                For Each objAttachment In objItem.Attachments
                    ' 保存附件，避免重名可添加序号（可选）
                    objAttachment.SaveAsFile savePath & objAttachment.FileName
                Next objAttachment
                
                ' 保存邮件本身为.msg文件到该文件夹
                objItem.SaveAs savePath & Format(objItem.ReceivedTime, "yyyy-mm-dd") & "_" & ReplaceIllegalChars(objItem.Subject) & ".msg", olMSG
            End If
        End If
    Next objItem
    
    ' 如果没有找到带附件的邮件，提示并结束
    If Not hasAttachmentEmails Then
        MsgBox "当前文件夹中没有带附件的邮件，宏已结束。", vbInformation
    Else
        MsgBox "所有带附件的邮件已处理完成！", vbInformation
    End If
    
    ' 释放对象
    Set objAttachment = Nothing
    Set objItem = Nothing
    Set objFolder = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing
End Sub

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

关键修改说明： #

• 自定义保存路径：修改代码开头的saveRootPath为你想要保存文件的根目录
• 指定目标文件夹：如果不是收件箱，把objNamespace.GetDefaultFolder(olFolderInbox)替换为你需要的文件夹，比如objNamespace.Folders("你的邮箱地址").Folders("自定义文件夹")
• 文件夹名称合法性：通过ReplaceIllegalChars函数自动替换掉Windows文件名不允许的特殊字符（比如:、*等），避免创建文件夹失败
• 保存邮件本身：新增了objItem.SaveAs方法，把邮件保存为.msg格式，和附件一起存到对应文件夹里
• 无附件邮件处理：通过hasAttachmentEmails标记，如果遍历完没有找到带附件的邮件，会弹出提示并结束宏

使用的时候直接把这段代码粘贴到Outlook的VBA编辑器里（按Alt+F11打开），调整好保存路径和目标文件夹后运行即可。

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