Home > Mobile >  Modify to Macro to attach 7 files instead of 1 file, Change Subject & Body accordingly
Modify to Macro to attach 7 files instead of 1 file, Change Subject & Body accordingly

Time:05-01

I am using this below code and is working fine, now the problem is that I need to attach 7 files from the folder

I have approx 150 Files and need help from some expert to modify to

  1. In the first email attach the first 7 files and then loop through and check the files and in the last email attach the balance three PDF files.

  2. Subject for the first email: Invoice 001 to Invoice 007 Body for First Email : Please find attached the following invoices Invoice 001 to Invoice 007 (7 invoices)

Subject for the last email: Invoice 148 to Invoice 150 Body for First Email : Please find attached the following invoices Invoice 148 to Invoice 150 (3 invoices)

Sub sendmailsss()
    
    Dim path As String
    Dim counter As Integer
    
    
    counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
    path = ThisWorkbook.Worksheets("Sheet").Range("M2")
    If ThisWorkbook.Worksheets("Sheet").Range("M2") = "" Then
    MsgBox "No folder selected. Please Select a folder with Invoives."
    Exit Sub
    End If
    fpath = path & "\*.pdf"
    fname = Dir(path)
    
    Dim OutApp As Outlook.Application
    Dim Source As String
    Dim subj() As String
    Do While fname <> ""
    subj = Split(fname, ".")
    Set OutApp = CreateObject("Outlook.Application")
    On Error GoTo 0
    Dim OutMail As Outlook.MailItem
    Dim OutAccount As Outlook.Account
    Set OutAccount = OutApp.Session.Accounts.Item(2)
    
    Set OutMail = OutApp.CreateItem(olMailItem)
    Source = path & fname
    With OutMail
        .To = "[email protected]"
        .Subject = "Company Ltd " & subj(0)
        .HTMLBody = "Invoice attached"
        .Attachments.Add Source
        .SendUsingAccount = OutAccount
    
        '.Display
        .Send
    End With
    If Err Then
          MsgBox "Error while sending Email" & vbLf & "Press OK to check it in the Outlook", vbExclamation
          '.Display
        Else
          
          ms = ms   1
        End If
        On Error GoTo 0
        Application.Wait Now   #12:00:10 AM#
    
    fname = Dir()
    'If ms = 3 Then
    'Exit Do
    'End If
    Loop
    MsgBox "Process Completed. " & ms & " emails sent."
    End Sub

CodePudding user response:

You should be able to adapt this into your existing code. What you need to do I think is add all the references to the attachment files to an array first. This will allow you to loop over them according to your specific counting requirements of 7 per e-mail:

 Sub SendMailSSS()
    
    Dim path As String
    'Dim counter As Integer
    Dim outApp As Outlook.Application
    Dim outMail As Outlook.MailItem
    Dim outAccount As Outlook.Account
    Dim source As String
    'Dim subj() As String
    Dim fPath As String
    Dim fName As String
    Dim fileList As Variant
    Dim innerLoop As Integer
    
    Dim fileCounter As Integer
    
    'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
    path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
    
    If path <> "" Then
    
        fileList = FncGetFilesFromPath(path & "\*.pdf")
        fileCounter = 0
        
        Do While fileCounter < UBound(fileList)
        
            Set outApp = CreateObject("Outlook.Application")
            Set outAccount = outApp.Session.Accounts.Item(2)
            Set outMail = outApp.CreateItem(olMailItem)
                
            With outMail
                
                .To = "[email protected]"
                .Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
                .HTMLBody = "Invoice attached"
                .SendUsingAccount = outAccount
                        
                'Gets next up to 7 files
                For innerLoop = fileCounter To (fileCounter   7)
                    
                    If innerLoop <= UBound(fileList) Then
                        
                          .Attachments.Add fileList(innerLoop)
                    
                    Else
                    
                        Exit For
                        
                    End If
                    
                Next innerLoop
            
            End With
            
            outMail.Send
            
            fileCounter = fileCounter   innerLoop
            
        Loop
    
    Else
    
        MsgBox "No folder selected. Please Select a folder with Invoices."
    
    End If
    
    Set outApp = Nothing
    Set outMail = Nothing
    Set outAccount = Nothing
    
End Sub

Private Function FncGetFilesFromPath(fPath As String) As Variant

    Dim result As Variant
    Dim fName As String
    Dim i As Integer
    
    ReDim result(0)
    i = 0
    
    fName = Dir(fPath)
    
    Do While fName <> ""
        
        ReDim Preserve result(i)
        result(i) = fPath & fName
        i = i   1
        
        fName = Dir()
        
    Loop
    
    FncGetFilesFromPath = result
    
End Function

I'm not sure what "subj" or "counter" are supposed to be doing in your code so I have commented them out. I cannot 100% test this, because I don't have Outlook on this machine, but it should give you the idea of how the looping will work.

CodePudding user response:

Here is the re-built code:

 Sub SendMailSSS()
    
    Dim path As String
    'Dim counter As Integer
    Dim outApp As Outlook.Application
    Dim outMail As Outlook.MailItem
    Dim outAccount As Outlook.Account
    Dim source As String
    'Dim subj() As String
    Dim fPath As String
    Dim fName As String
    Dim fileList As Variant
    Dim innerLoop As Integer
    
    Dim fileCounter As Integer
    
    'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
    path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
    
    If path <> "" Then
    
        fileList = FncGetFilesFromPath(path)
        fileCounter = 0
        
        Do While fileCounter < UBound(fileList)
        
            Set outApp = CreateObject("Outlook.Application")
            Set outAccount = outApp.Session.Accounts.Item(2)
            Set outMail = outApp.CreateItem(olMailItem)
                
            With outMail
                
                .To = "[email protected]"
                .Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
                .HTMLBody = "Invoice attached"
                .SendUsingAccount = outAccount
                        
                'Gets next up to 7 files
                For innerLoop = fileCounter To (fileCounter   7)
                    
                    If innerLoop <= UBound(fileList) Then
                        
                          .Attachments.Add fileList(innerLoop)
                    
                    Else
                    
                        Exit For
                        
                    End If
                    
                Next innerLoop
            
            End With
            
            outMail.Send
            
            fileCounter = fileCounter   innerLoop
            
        Loop
    
    Else
    
        MsgBox "No folder selected. Please Select a folder with Invoices."
    
    End If
    
    Set outApp = Nothing
    Set outMail = Nothing
    Set outAccount = Nothing
    
End Sub

Private Function FncGetFilesFromPath(fPath As String) As Variant

    Dim result As Variant
    Dim fName As String
    Dim i As Integer
    
    ReDim result(0)
    i = 0
    
    fName = Dir(fPath)
    
    Do While fName <> ""
        
        ReDim Preserve result(i)
        result(i) = fPath & fName
        i = i   1
        
        fName = Dir()
        
    Loop
    
    FncGetFilesFromPath = result
    
End Function
  • Related