CODEWITHSUNDEEP
vbaemailoutlookoutlook-2010
0m3r
0m3r

Reputation: 12499

Sending files via one or more emails with at most 10 attachments each

I'm trying to send all files in a folder as email attachments, with at most 10 attachments per message.

So I put together the following macro to attach all files to an email message and send it then move the files, which is working great

But now that I'm trying to send 10 files per message then the next 10 files in the folder, repeating until all files are sent.

I have tried several way but did not work.

how do I terminate Do While loop after 10 Attachments and the move the Code to the next statement?

    attchFile = Dir(attchPath & "*.*")

    '// Loop to attch
    Do While Len(attchFile) > 0
        .Attachments.Add attchPath & attchFile
        sExtension = Right(attchFile, _
                             Len(attchFile) - InStrRev(attchFile, Chr(46)))

        '// Check if the file exists and save with unique name
        oldName = attchFile
        NewName = FileNameUnique(MovePath, attchFile, sExtension)

        '// Move the files.
        Name attchPath & oldName As MovePath & NewName
        attchFile = Dir
    Loop

    '// Cancell email if no files to send
    If .Attachments.Count = 0 Then
        .Close 0
        .Delete
    Else

If you need complete code, let me know.

Edit

Here is the complete code.

Option Explicit
Sub SendFiles()
    Dim olApp As Outlook.Application
    Dim olMsg As Outlook.MailItem
    Dim olRecip As Outlook.Recipient
    Dim attchPath As String
    Dim MovePath As String
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim olRng As Object
    Dim attchFile As String
    Dim sExtension As String
    Dim NewName As String
    Dim oldName As String

    '// Attachments Path.
    attchPath = "C:\Files\"

    '// Move Path.
    MovePath = "C:\Completed\"

'    On Error GoTo lbl_Exit
    '// Set Outlook.
    Set olApp = Outlook.Application

    '// Create the message.
    Set olMsg = olApp.CreateItem(olMailItem)
    With olMsg
        .Display        '// This line must be retained

        attchFile = Dir(attchPath & "*.*")

        '// Loop to attch
        Do While Len(attchFile) > 0
            .Attachments.Add attchPath & attchFile
            sExtension = Right(attchFile, _
                                 Len(attchFile) - InStrRev(attchFile, Chr(46)))

            '// Check if the file exists and save with unique name
            oldName = attchFile
            NewName = FileNameUnique(MovePath, attchFile, sExtension)

            '// Move the files.
            Name attchPath & oldName As MovePath & NewName
            attchFile = Dir
        Loop


        '// Cancell email if no files to send
        If .Attachments.Count = 0 Then
            'MsgBox "There are no reports to attach.", vbInformation
            .Close 0
            .Delete
        Else

            '// Add the To recipient(s)
            Set olRecip = .Recipients.Add("Email")
            Set olRecip = .Recipients.Add("Email")
            olRecip.Type = olTo

            '// Add the CC recipient(s)
            Set olRecip = .Recipients.Add("Email")
            olRecip.Type = olCC

            '// Set the Subject, Body, and Importance of the message.
            .Subject = "Reports - " & Format(Now, "Long Date")
            .Importance = olImportanceHigh        '// High importance
            .BodyFormat = olFormatHTML

            '// Edit the message body.
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor

            '// Set message body (to retain the signature)
            Set olRng = wdDoc.Range(0, 0)

            '// add the text to message body
            olRng.text = "Attached files has been Completed, Thank you" & vbCrLf & vbCrLf


            '// Resolve each Recipient's name.
            For Each olRecip In .Recipients
                olRecip.Resolve
                If Not olRecip.Resolve Then
                    olMsg.Display
                End If

            Next
            '.DeleteAfterSubmit = True
            .Send '//This line optional
        End If
    End With

lbl_Exit:

    Set olMsg = Nothing
    Set olApp = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set olRng = Nothing
    Exit Sub
End Sub

'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(FullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

'// If the same file name exist in Completed Path folder then add (1)
Private Function FileNameUnique(sPath As String, _
                               FileName As String, _
                               sExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(FileName) - (Len(sExtension) + 1)
    FileName = Left(FileName, lngName)
    Do While FileExists(sPath & FileName & Chr(46) & sExtension) = True
        FileName = Left(FileName, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = FileName & Chr(46) & sExtension
lbl_Exit:
    Exit Function
End Function

Upvotes: 0

Views: 274

Answers (1)

VirtualMichael
VirtualMichael

Reputation: 721

Try putting the mail creation code within a loop of its own. Get the inner attach loop to abort after adding up to 10 attachments, and the outer loop will abort only once there are no remaining files to add.

The following code modifies your method immediately below the line Set olApp = Outlook.Application

attchFile = Dir(attchPath & "*.*")
'// Cancel email if no files to send
If Len(attchFile) = 0 Then
    MsgBox "There are no reports to attach.", vbInformation
Else
    Do While Len(attchFile) > 0

        '// Create the message.
        Set olMsg = olApp.CreateItem(olMailItem)
        With olMsg
            .Display        '// This line must be retained

            '// Loop to attach files
            Do While Len(attchFile) > 0 And .Attachments.Count < 10
                .Attachments.Add attchPath & attchFile
                sExtension = Right(attchFile, _
                                     Len(attchFile) - InStrRev(attchFile, Chr(46)))

                '// Check if the file exists and save with unique name
                oldName = attchFile
                NewName = FileNameUnique(MovePath, attchFile, sExtension)

                '// Move the files.
                Name attchPath & oldName As MovePath & NewName
                '// Look for the next attachment to be added
                attchFile = Dir(attchPath & "*.*")
            Loop

            '// Add the To recipient(s)
            Set olRecip = .Recipients.Add("Email")
            Set olRecip = .Recipients.Add("Email")
            olRecip.Type = olTo

            '// Add the CC recipient(s)
            Set olRecip = .Recipients.Add("Email")
            olRecip.Type = olCC

            '// Set the Subject, Body, and Importance of the message.
            .Subject = "Reports - " & Format(Now, "Long Date")
            .Importance = olImportanceHigh        '// High importance
            .BodyFormat = olFormatHTML

            '// Edit the message body.
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor

            '// Set message body (to retain the signature)
            Set olRng = wdDoc.Range(0, 0)

            '// add the text to message body
            olRng.Text = "Attached files has been Completed, Thank you" & vbCrLf & vbCrLf

            '// Resolve each Recipient's name.
            For Each olRecip In .Recipients
                olRecip.Resolve
                If Not olRecip.Resolve Then
                    olMsg.Display
                End If
            Next
            '.DeleteAfterSubmit = True
            .Send
        End With
    Loop
End If

Upvotes: 2

Related Questions