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

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

更新

添加了.HTMLBody而非.Body，以使文本加粗并带有下划线
您可以使用更多的HTML命令来使“文本粗体”和“更多”的某些部分。

Answer 2

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

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)

Answer 3

尝试一下。

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

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

3 个答案: