Your current VBA script already nails creating a daily folder structure and saving attachments—we just need to add a few lines to save the actual email as a .msg file alongside those attachments. Here's how to modify your code to handle both tasks seamlessly:

Modified VBA Code #

Option Explicit
' Define Outlook save format constant for late binding (skip if using early binding)
Const olMSG As Integer = 3

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
    Dim objAtt As Outlook.Attachment
    Dim SaveFolder As String
    Dim emailFileName As String
    
    ' Build the daily folder path (same as your original logic)
    SaveFolder = "C:\Temp\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date)
    
    ' Create folder hierarchy if it doesn't exist (simplified checks)
    If Len(Dir("C:\Temp\" & Year(Date), vbDirectory)) = 0 Then
        MkDir "C:\Temp\" & Year(Date)
    End If
    If Len(Dir(SaveFolder, vbDirectory)) = 0 Then
        MkDir SaveFolder
    End If
    
    ' Create a valid filename for the email (clean up illegal characters)
    emailFileName = itm.Subject
    ' Replace Windows filename-invalid characters with underscores
    emailFileName = Replace(emailFileName, "\", "_")
    emailFileName = Replace(emailFileName, "/", "_")
    emailFileName = Replace(emailFileName, ":", "_")
    emailFileName = Replace(emailFileName, "*", "_")
    emailFileName = Replace(emailFileName, "?", "_")
    emailFileName = Replace(emailFileName, """", "_")
    emailFileName = Replace(emailFileName, "<", "_")
    emailFileName = Replace(emailFileName, ">", "_")
    emailFileName = Replace(emailFileName, "|", "_")
    
    ' Fallback for empty email subjects
    If emailFileName = "" Then
        emailFileName = "Untitled_Email_" & Format(Date, "yyyymmdd")
    End If
    ' Add date prefix and .msg extension
    emailFileName = Format(Date, "yyyymmdd") & "_" & emailFileName & ".msg"
    
    ' Save the email itself as .msg (add basic error handling)
    On Error Resume Next ' Skip if file already exists or save fails
    itm.SaveAs SaveFolder & "\" & emailFileName, olMSG
    On Error GoTo 0
    
    ' Save attachments (your original code, kept intact)
    For Each objAtt In itm.Attachments
        objAtt.SaveAsFile SaveFolder & "\" & Format(Date, "yyyymmdd") & "_" & objAtt.DisplayName
    Next
    
    Set objAtt = Nothing
End Sub

Key Changes Explained #

• Added olMSG constant: This tells Outlook to save the item as a standard .msg file. If you're using early binding (you've referenced the Outlook Object Library via Tools > References), you can skip defining this constant—Outlook will recognize olMSG natively.
• Validated email filenames: Windows blocks certain characters in filenames, so we replace all illegal ones with underscores to avoid save errors. We also added a fallback name for emails with empty subjects.
• Core itm.SaveAs call: This is the new line that saves the full email to your daily folder, matching the naming pattern you use for attachments.
• Basic error handling: The On Error Resume Next ensures the script doesn't crash if a .msg file with the same name already exists (you could extend this to append a number to duplicate filenames if needed).

Quick Setup Notes #

1. Replace your existing saveAttachtoDisk subroutine with this modified version.
2. If you get an Outlook-related error, double-check that your VBA project has access to the Outlook Object Library (go to Tools > References > check "Microsoft Outlook [Your Version] Object Library").
3. Test the script on an email—you’ll now see both the .msg file and your attachments in the daily folder structure.

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