在 VBA 中使用带附件的范围发送多封电子邮件

Question

这是我第一次尝试从 Excel 使用 VBA 代码发送电子邮件。

这是我的 Excel 结构。有时电子邮件列表会有 1 - 20 个或只有 1 个

A (col) B          C         D        E     F              G
Sl.No  First Name To Email  CC Email Subj   File to Send   Message

代码：

Option Explicit

Sub SendMail()

Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With ActiveSheet
Set rngTo = .Range("C2")
Set rngSubject = .Range("E2")
Set rngBody = .Range("G2")
Set rngAttach = .Range("F2")
End With

With objMail
    .To = rngTo.Value
    .Subject = rngSubject.Value
    .Body = rngBody.Value
    .Attachments.Add rngAttach.Value
    .Display

End With

Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub

这是我的代码，它工作得非常好，但用于发送单封电子邮件，但不适用于多封电子邮件。

我在这里苦苦寻找如何使用经过测试的代码发送多个带有附件的电子邮件。

Answer 1

不妨试试这个：

Option Explicit

Sub SendMail()

Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim rngBody As Range
Dim rngAttach As Range
Dim i As Integer

Set objOutlook = CreateObject("Outlook.Application")


For i = 2 To 21 ' Loop from 2 to 21


    With ActiveSheet
    Set rngTo = .Range("C" & i)
    Set rngSubject = .Range("E" & i)
    Set rngBody = .Range("G" & i)
    Set rngAttach = .Range("F" & i)
    End With

    Set objMail = objOutlook.CreateItem(0)

    With objMail
        .To = rngTo.Value
        .Subject = rngSubject.Value
        .HTMLBody = "<B><U>" & rngBody.Value & ":</B></U>"
        .Attachments.Add rngAttach.Value
        .Display

    End With

    Set objMail = Nothing

Next

Set objOutlook = Nothing
Set rngTo = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
Set rngAttach = Nothing
End Sub

您可以遍历 Range 以生成 20 封电子邮件。

---

更新

• 添加了.HTMLBody 而不是.Body 以使文本变为粗体和下划线

• 您可以使用更多的 HTML 命令使文本的某些部分变为粗体和更多。

Answer 2

试试这个方法。

Make a list in Sheets("Sheet1") with :

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

https://www.rondebruin.nl/win/s1/outlook/amail6.htm

Answer 3

你需要一个循环。下面的代码将从第二行开始，直到找到一个空行。

Option Explicit

Sub SendMail()
    Dim objOutlook As Object
    Dim objMail As Object
    Dim rngTo As Range
    Dim rngSubject As Range
    Dim rngBody As Range
    Dim rngAttach As Range

    Set objOutlook = CreateObject("Outlook.Application")

    Dim r As Long: For r = 2 To ActiveSheet.Range("C2").End(xlDown).Row
        With ActiveSheet
            Set rngTo = .Range("C" & r)
            Set rngSubject = .Range("E" & r)
            Set rngBody = .Range("G" & r)
            Set rngAttach = .Range("F" & r)
        End With

        Set objMail = objOutlook.CreateItem(0)
        With objMail
            .to = rngTo.Value
            .Subject = rngSubject.Value
            .Body = rngBody.Value
            .Attachments.Add rngAttach.Value
            .Display
            .Send ' If you want to send it without clicking
        End With
    Next
End Sub

另请注意：These Set x = Nothing 行是多余的，请删除它们，因为它们只会使代码对人类的可读性降低。关于这个问题你也可以参考这个SO问题：Is there a need to set Objects to Nothing inside VBA Functions

更新

对不起，这行必须在循环内，我更新了代码：

Set objMail = objOutlook.CreateItem(0)