Step-by-Step guide to download attachments from Outlook using VB Macro

				
					Option Explicit

Sub SaveExcelAttachments_Simple()
    Dim ns As Outlook.NameSpace
    Dim st As Outlook.store
    Dim root As Outlook.MAPIFolder
    Dim f1 As Outlook.MAPIFolder
    Dim f2 As Outlook.MAPIFolder
    Dim itms As Outlook.items
    Dim i As Long
    Dim mail As Outlook.MailItem
    Dim att As Outlook.Attachment
    Dim saveFolder As String
    Dim saved As Long, scanned As Long
    
    ' ==== Settings (adjust if needed) ====
    Const MAILBOX_NAME As String = "<mail_box_name ex mayank@example.com>"
    Const FOLDER_PATH As String = "<Sub Folder Path>" ' under the mailbox root
    saveFolder = "C:\Temp\OutlookXlsx"
    ' =====================================

    Set ns = Application.GetNamespace("MAPI")

    ' Find mailbox root
    For Each st In ns.Stores
        If StrComp(st.DisplayName, MAILBOX_NAME, vbTextCompare) = 0 Then
            Set root = st.GetDefaultFolder(olFolderInbox).Parent
            Exit For
        End If
    Next st
    If root Is Nothing Then
        MsgBox "Mailbox not found: " & MAILBOX_NAME, vbExclamation
        Exit Sub
    End If

    ' Walk to the target folder 
    Set f1 = Nothing: Set f2 = Nothing
    On Error Resume Next
    Set f1 = root.Folders("<SubFolder1>")
    If Not f1 Is Nothing Then Set f2 = f1.Folders("<SubFolder2>")
    On Error GoTo 0
    If f2 Is Nothing Then
        MsgBox "Folder not found: " & FOLDER_PATH, vbExclamation
        Exit Sub
    End If

    ' Ensure save directory exists
    CreateFolderIfMissing saveFolder

    ' Get items and sort (newest first)
    Set itms = f2.items
    itms.Sort "[ReceivedTime]", True

    ' Loop emails and save Excel attachments
    For i = 1 To itms.count
        If TypeOf itms(i) Is Outlook.MailItem Then
            Set mail = itms(i)
            scanned = scanned + 1

            If mail.Attachments.count > 0 Then
                For Each att In mail.Attachments
                    If IsExcelAttachment(att.fileName) Then
                        Dim ts As String
                        Dim cleanAttach As String
                        Dim targetPath As String
                        
                        ts = Format(mail.ReceivedTime, "yyyy-mm-dd_hhmmss")
                        cleanAttach = SanitizeFileName(att.fileName)
                        
                        targetPath = EnsureUniquePath(saveFolder, ts & " - " & cleanAttach)
                        att.SaveAsFile targetPath
                        saved = saved + 1
                    End If
                Next att
            End If
        End If
    Next i

    MsgBox "Done!" & vbCrLf & _
           "Folder: " & f2.folderPath & vbCrLf & _
           "Emails scanned: " & scanned & vbCrLf & _
           "Excel attachments saved: " & saved & vbCrLf & _
           "Saved to: " & saveFolder, vbInformation
End Sub

' --- Helpers ---

Private Function IsExcelAttachment(fileName As String) As Boolean
    Dim ext As String
    ext = LCase$(Mid$(fileName, InStrRev(fileName, ".") + 1))
    Select Case ext
        Case "xlsx", "xls", "xlsm", "xlsb", "csv"
            IsExcelAttachment = True
        Case Else
            IsExcelAttachment = False
    End Select
End Function

Private Function SanitizeFileName(ByVal s As String) As String
    ' Remove characters invalid for Windows filenames
    Dim badChars As Variant, ch As Variant
    badChars = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
    For Each ch In badChars
        s = Replace$(s, ch, " ")
    Next ch
    ' Collapse double spaces
    Do While InStr(s, "  ") > 0
        s = Replace$(s, "  ", " ")
    Loop
    SanitizeFileName = Trim$(s)
End Function

Private Sub CreateFolderIfMissing(ByVal path As String)
    If Len(Dir$(path, vbDirectory)) = 0 Then
        MkDir path
    End If
End Sub

Private Function EnsureUniquePath(ByVal folder As String, ByVal fileName As String) As String
    ' If file exists, append (1), (2), ...
    Dim base As String, ext As String, p As Long, candidate As String
    Dim n As Long
    
    p = InStrRev(fileName, ".")
    If p > 0 Then
        base = Left$(fileName, p - 1)
        ext = Mid$(fileName, p)          ' includes dot
    Else
        base = fileName
        ext = ""
    End If
    
    candidate = folder & "\" & fileName
    n = 1
    Do While Len(Dir$(candidate)) > 0
        candidate = folder & "\" & base & " (" & n & ")" & ext
        n = n + 1
    Loop
    
    EnsureUniquePath = candidate
End Function