Search code examples
excelvba

Add multiple attachments from different folders

How can I add attachments to my code using specific file pathways in H, I, J, K?

sheet 1

I can only select an entire folder. The items I would like to attach are in different folders, as I'm sending different files specific to each recipient listed.

I would like to stop showing the folder selection pop up. I want to manually add the file pathways for attachments for the corresponding recipient. I will have a maximum of four attachments.

Sub ComposeEmails()
    Dim OutApp As Object
    Dim OutNS As Object
    Dim DraftsFolder As Object
    Dim OutMail As Object
    Dim FileSystem As Object
    Dim Folder As Object
    Dim FileItem As Object
    Dim FolderPath As String
    Dim i As Long
    Dim hasAttachments As Boolean
    Dim Account As Object
    Dim AccountIndex As Long
    Dim selectedAccount As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutNS = OutApp.GetNamespace("MAPI")

    ' List available accounts and let user choose
    Dim accStr As String
    For i = 1 To OutNS.accounts.Count
        accStr = accStr & i & ". " & OutNS.accounts.Item(i).SmtpAddress & vbNewLine
    Next i

    selectedAccount = InputBox("Choose the account to send emails from:" & vbNewLine & accStr)

    If selectedAccount = "" Then
        MsgBox "No account selected. Exiting.", vbExclamation, "Information"
        Exit Sub
    End If

    AccountIndex = CLng(selectedAccount)
    Set Account = OutNS.accounts.Item(AccountIndex)
    Set DraftsFolder = OutNS.Folders(Account.DeliveryStore.DisplayName).Folders("Drafts")

    ' Folder selection dialog
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select the folder containing attachments"
        .Show
        If .SelectedItems.Count > 0 Then
            FolderPath = .SelectedItems(1) & "\"
            hasAttachments = True
        Else
            MsgBox "No folder selected. Emails will be composed without attachments.", vbExclamation, "Information"
            hasAttachments = False
        End If
    End With

    Application.ScreenUpdating = False

    For i = 2 To ThisWorkbook.Sheets("Market 70").Cells(Rows.Count, 2).End(xlUp).Row
        Set OutMail = DraftsFolder.Items.Add("IPM.Note")

        With OutMail
            .To = ThisWorkbook.Sheets("Market 70").Cells(i, 3).Value
            .CC = ThisWorkbook.Sheets("Market 70").Cells(i, 5).Value
            .Subject = ThisWorkbook.Sheets("Market 70").Cells(i, 6).Value
            .Body = "Hi " & ThisWorkbook.Sheets("Market 70").Cells(i, 2).Value & "," & vbNewLine & vbNewLine & _
                    ThisWorkbook.Sheets("Market 70").Cells(i, 7).Value & vbNewLine & vbNewLine

            If hasAttachments Then
                Set FileSystem = CreateObject("Scripting.FileSystemObject")
                Set Folder = FileSystem.GetFolder(FolderPath)
                For Each FileItem In Folder.Files
                    .Attachments.Add (FileItem.Path)
                Next FileItem
            End If

            .Save
            .Display
        End With

        Set OutMail = Nothing
        Set FileSystem = Nothing
        Set Folder = Nothing
    Next i

    Application.ScreenUpdating = True
    Set OutApp = Nothing
    Set OutNS = Nothing
    Set DraftsFolder = Nothing
End Sub
    
    
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
End Sub
Solution

  • Try the following. I've just commented out your unwanted code, in case you want to go back to it. You can delete it if you want.

    The new lines under 'Loop through columns 8 to 11 (H to K) should do what you want, but you'll have to be careful to ensure the files actually exist at those paths. If that can't be done reliably, you can look at adding some error handling for what to do if there is no file at that path.

    Sub change_()

Dim OutApp As Object
        Dim OutNS As Object
        Dim DraftsFolder As Object
        Dim OutMail As Object
        Dim FileSystem As Object
        Dim Folder As Object
        Dim FileItem As Object
        Dim FolderPath As String
        Dim i As Long, j As Long
        Dim hasAttachments As Boolean
        Dim Account As Object
        Dim AccountIndex As Long
        Dim selectedAccount As String
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutNS = OutApp.GetNamespace("MAPI")
    
        ' List available accounts and let user choose
        Dim accStr As String
        For i = 1 To OutNS.accounts.Count
            accStr = accStr & i & ". " & OutNS.accounts.Item(i).SmtpAddress & vbNewLine
        Next i
    
        selectedAccount = InputBox("Choose the account to send emails from:" & vbNewLine & accStr)
    
        If selectedAccount = "" Then
            MsgBox "No account selected. Exiting.", vbExclamation, "Information"
            Exit Sub
        End If
    
        AccountIndex = CLng(selectedAccount)
        Set Account = OutNS.accounts.Item(AccountIndex)
        Set DraftsFolder = OutNS.Folders(Account.DeliveryStore.DisplayName).Folders("Drafts")
    
'        ' Folder selection dialog
'        With Application.FileDialog(msoFileDialogFolderPicker)
'            .Title = "Select the folder containing attachments"
'            .Show
'            If .SelectedItems.Count > 0 Then
'                FolderPath = .SelectedItems(1) & "\"
'                hasAttachments = True
'            Else
'                MsgBox "No folder selected. Emails will be composed without attachments.", vbExclamation, "Information"
'                hasAttachments = False
'            End If
'        End With
    
        Application.ScreenUpdating = False
    
        For i = 2 To ThisWorkbook.Sheets("Market 70").Cells(Rows.Count, 2).End(xlUp).Row
            Set OutMail = DraftsFolder.Items.Add("IPM.Note")
    
            With OutMail
                .To = ThisWorkbook.Sheets("Market 70").Cells(i, 3).Value
                .CC = ThisWorkbook.Sheets("Market 70").Cells(i, 5).Value
                .Subject = ThisWorkbook.Sheets("Market 70").Cells(i, 6).Value
                .Body = "Hi " & ThisWorkbook.Sheets("Market 70").Cells(i, 2).Value & "," & vbNewLine & vbNewLine & _
                        ThisWorkbook.Sheets("Market 70").Cells(i, 7).Value & vbNewLine & vbNewLine
    
'                If hasAttachments Then
'                    Set FileSystem = CreateObject("Scripting.FileSystemObject")
'                    Set Folder = FileSystem.GetFolder(FolderPath)
'                    For Each FileItem In Folder.Files
'                        .Attachments.Add (FileItem.Path)
'                    Next FileItem
'                End If

                'Loop through columns 8 to 11 (H to K)
                For j = 8 To 11
                    If ThisWorkbook.Sheets("Market 70").Cells(i, j).Value <> "" Then
                        .attachments.Add ThisWorkbook.Sheets("Market 70").Cells(i, j).Value
                    End If
                Next j
    
                .Save
                .Display
            End With
    
            Set OutMail = Nothing
            Set FileSystem = Nothing
            Set Folder = Nothing
        Next i
    
        Application.ScreenUpdating = True
        Set OutApp = Nothing
        Set OutNS = Nothing
        Set DraftsFolder = Nothing
    End Sub