Creating separate folders to save attachments

Question

I am trying to look through old emails to scan them to save the attachment and the email while creating separate folders for said attachment.

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

This program ran for the first attachment and saved it but didn't create a folder and gave me this error.

Run-time error '-2147024893 (80070003)': Cannot save the attachment. Path does not exist. Verify the path is correct

on

o1Attachment.SaveAsFile FullFolderPath & CleanedFileName

First screenshot of code. Second Screenshot of code. Error Message

Answer 1

This:

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

...can silently fail without you knowing, so it would be better to replace it with a separate method which can be called from your main code, something like:

If Not EnsurePathExists(FullFolderPath) Then Exit Sub

Ensure folder exists:

'Given a folder path, make sure the complete path exists
Function EnsurePathExists(pathToCheck As String) As Boolean
    Dim ps As String, arr, i As Long, p As String, exists As Boolean
    
    On Error GoTo haveError
    ps = Application.PathSeparator
    arr = Split(pathToCheck, ps)
    p = ""
    
    For i = 0 To UBound(arr)
        If Len(arr(i)) > 0 Then        'check for empty part...
            p = p & arr(i) & ps
            exists = FolderExists(p)
            Debug.Print IIf(exists, "Exists: ", "Creating: "), p
            If Not exists Then MkDir p 'create folder if required
        End If
    Next i
    EnsurePathExists = True    'success
    Exit Function
haveError:
    MsgBox "Error creating folder path '" & pathToCheck & "':" & vbLf & Err.Description, vbCritical
    EnsurePathExists = False   'failed to complete folder path
End Function

'does `p` refer to an existing folder?
Function FolderExists(p As String) As Boolean
    On Error Resume Next
    FolderExists = ((GetAttr(p) And vbDirectory) = vbDirectory)
End Function

Answer 2

Attachment.SaveAsFile will not create a folder if it does not exist. That is your responsibility.