通过一封或多封电子邮件发送文件，每封邮件最多包含10个附件

Question

我正在尝试将文件夹中的所有文件作为电子邮件附件发送，每封邮件最多包含10个附件。

因此，我将以下宏放在一起，将所有文件附加到电子邮件中并发送，然后移动文件，这很有效

但是现在我正在尝试每封邮件发送10个文件，然后文件夹中的下10个文件，重复直到所有文件都被发送。

我尝试了几种方法，但没有用。

如何在10个附件后终止 Do While loop 并将代码移至下一个声明？

    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

如果您需要完整的代码，请与我们联系。

修改

这是完整的代码。

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

Answer 1

尝试将邮件创建代码放在自己的循环中。在添加最多10个附件后，让内部附加循环中止，只有在没有剩余文件要添加时，外部循环才会中止。

以下代码会在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