Outlook VBA保存附件报错：路径不存在问题求助

运行以下VBA代码遍历旧邮件、保存附件并按「发件人域名+年月」创建文件夹时，首个附件保存后未生成对应文件夹，触发运行时错误'-2147024893 (80070003)'，提示「无法保存附件，路径不存在，请验证路径是否正确」，错误发生在代码行：

olAttachment.SaveAsFile FullFolderPath & CleanedFileName

Sub SaveAttachmentsToDynamicFolders()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olAttachment As Outlook.Attachment
    Dim FilePath As String
    Dim DomainFolder As String
    Dim YearMonthFolder As String
    Dim FullFolderPath As String
    Dim SenderEmail As String
    Dim i As Integer
    Dim ReceivedDate As Date
    Dim CleanedFileName As String
    Dim StartDate As Date
    Dim EndDate As Date
    
    ' Base path to OneDrive folder where attachments will be saved
    FilePath = "C:\Users\s\PastEmailAttachments\"
    
    ' Define the date range
    StartDate = DateSerial(2024, 1, 1) ' Adjust start date as needed
    EndDate = DateSerial(2024, 12, 31) ' Adjust end date as needed
 
    ' Initialize Outlook objects
    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
 
    ' Loop through each item in the folder
    For Each olItem In olFolder.Items
        ' Check if the item is an email
        If TypeName(olItem) = "MailItem" Then
            ' Get the received date of the email
            ReceivedDate = olItem.ReceivedTime
            
            ' Check if the email falls within the specified date range
            If ReceivedDate >= StartDate And ReceivedDate <= EndDate Then
                ' Get the sender's email address
                SenderEmail = olItem.SenderEmailAddress
                ' Extract the domain from the email address
                DomainFolder = Mid(SenderEmail, InStr(SenderEmail, "@") + 1)
 
                ' Create the Year/Month folder structure
                YearMonthFolder = Year(ReceivedDate) & "\" & Format(ReceivedDate, "MM")
 
                ' Combine the paths to create the full folder path
                FullFolderPath = FilePath & DomainFolder & "\" & YearMonthFolder & "\"
 
                ' Ensure each directory level exists
                On Error Resume Next ' Skip errors if directory already exists
                MkDir FilePath & DomainFolder
                MkDir FilePath & DomainFolder & "\" & Year(ReceivedDate)
                MkDir FullFolderPath
                On Error GoTo 0 ' Reset error handling
 
                ' Loop through each attachment in the email
                For i = 1 To olItem.Attachments.Count
                    Set olAttachment = olItem.Attachments(i)
                    
                    ' Clean the file name
                    CleanedFileName = CleanFileName(olAttachment.FileName)
                    
                    ' Debug print the full path and file name
                    Debug.Print FullFolderPath & CleanedFileName
                    
                    ' Save the attachment to the specified folder
                    olAttachment.SaveAsFile FullFolderPath & CleanedFileName
                Next i
            End If
        End If
    Next olItem
 
    ' Cleanup
    Set olAttachment = Nothing
    Set olItem = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
 
    MsgBox "Attachments have been saved to the OneDrive folder.", vbInformation
End Sub
 
' Function to clean file names by replacing invalid characters
Function CleanFileName(ByVal FileName As String) As String
    Dim InvalidChars As String
    Dim Char As String
    InvalidChars = "<>:/\|?*"""
 
    For i = 1 To Len(InvalidChars)
        Char = Mid(InvalidChars, i, 1)
        FileName = Replace(FileName, Char, "_")
    Next i
 
    CleanFileName = FileName
End Function

1. 发件人地址格式异常：当发件人为Exchange内部用户时，SenderEmailAddress返回Exchange专有格式（而非SMTP地址），提取的DomainFolder包含大量非法字符，无法创建文件夹。
2. 文件夹创建逻辑缺陷：MkDir仅支持创建单级目录，若父目录创建失败（如含非法字符），后续子目录创建也会失败，但On Error Resume Next会掩盖错误，导致最终路径不存在。
3. 目录名未做非法字符清理：即使是合法SMTP域名，若包含Windows文件夹名禁止的字符，也会导致文件夹创建失败。

1. 修正发件人邮箱获取逻辑 #

添加函数专门提取发件人的SMTP地址，规避Exchange格式干扰。

2. 递归创建多级目录 #

替换MkDir为递归创建目录的函数，确保所有父目录都能正确生成。

3. 清理目录名非法字符 #

对DomainFolder执行非法字符替换，确保目录名符合Windows规范。

Sub SaveAttachmentsToDynamicFolders()
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olAttachment As Outlook.Attachment
    Dim FilePath As String
    Dim DomainFolder As String
    Dim YearMonthFolder As String
    Dim FullFolderPath As String
    Dim SenderEmail As String
    Dim i As Integer
    Dim ReceivedDate As Date
    Dim CleanedFileName As String
    Dim StartDate As Date
    Dim EndDate As Date
    
    ' 附件保存根路径
    FilePath = "C:\Users\s\PastEmailAttachments\"
    
    ' 设定日期范围
    StartDate = DateSerial(2024, 1, 1)
    EndDate = DateSerial(2024, 12, 31)
 
    ' 初始化Outlook对象
    Set olApp = Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)
 
    ' 遍历收件箱邮件
    For Each olItem In olFolder.Items
        If TypeName(olItem) = "MailItem" Then
            ReceivedDate = olItem.ReceivedTime
            If ReceivedDate >= StartDate And ReceivedDate <= EndDate Then
                ' 获取合法的SMTP发件人地址
                SenderEmail = GetSMTPAddress(olItem)
                If SenderEmail <> "" Then
                    ' 提取域名并清理非法字符
                    DomainFolder = Mid(SenderEmail, InStr(SenderEmail, "@") + 1)
                    DomainFolder = CleanFileName(DomainFolder)
 
                    ' 构建文件夹路径
                    YearMonthFolder = Year(ReceivedDate) & "\" & Format(ReceivedDate, "MM")
                    FullFolderPath = FilePath & DomainFolder & "\" & YearMonthFolder & "\"
 
                    ' 递归创建所有层级目录
                    CreateDirectory FullFolderPath
 
                    ' 保存附件
                    For i = 1 To olItem.Attachments.Count
                        Set olAttachment = olItem.Attachments(i)
                        CleanedFileName = CleanFileName(olAttachment.FileName)
                        Debug.Print FullFolderPath & CleanedFileName
                        olAttachment.SaveAsFile FullFolderPath & CleanedFileName
                    Next i
                End If
            End If
        End If
    Next olItem
 
    ' 释放对象
    Set olAttachment = Nothing
    Set olItem = Nothing
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
 
    MsgBox "附件已保存至指定文件夹。", vbInformation
End Sub
 
' 清理文件名/目录名中的非法字符
Function CleanFileName(ByVal FileName As String) As String
    Dim InvalidChars As String
    Dim Char As String
    InvalidChars = "<>:/\|?*"""
 
    For i = 1 To Len(InvalidChars)
        Char = Mid(InvalidChars, i, 1)
        FileName = Replace(FileName, Char, "_")
    Next i
 
    CleanFileName = FileName
End Function
 
' 获取发件人SMTP地址，兼容Exchange用户
Function GetSMTPAddress(ByVal MailItem As Outlook.MailItem) As String
    Dim olSender As Outlook.AddressEntry
    Dim olExchangeUser As Outlook.ExchangeUser
    Dim olExchangeDistributionList As Outlook.ExchangeDistributionList
 
    Set olSender = MailItem.Sender
    If olSender.AddressEntryUserType = olExchangeUserAddressEntry Then
        Set olExchangeUser = olSender.GetExchangeUser
        If Not olExchangeUser Is Nothing Then
            GetSMTPAddress = olExchangeUser.PrimarySmtpAddress
        End If
    ElseIf olSender.AddressEntryUserType = olExchangeDistributionListAddressEntry Then
        Set olExchangeDistributionList = olSender.GetExchangeDistributionList
        If Not olExchangeDistributionList Is Nothing Then
            GetSMTPAddress = olExchangeDistributionList.PrimarySmtpAddress
        End If
    Else
        GetSMTPAddress = MailItem.SenderEmailAddress
    End If
End Function
 
' 递归创建目录及所有父目录
Sub CreateDirectory(ByVal Path As String)
    Dim ParentPath As String
    If Dir(Path, vbDirectory) = "" Then
        ParentPath = Left(Path, InStrRev(Path, "\") - 1)
        If ParentPath <> "" Then
            CreateDirectory ParentPath
        End If
        MkDir Path
    End If
End Sub

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