使用 4 列中的电子邮件地址发送邮件

Question

我使用 Ron de Bruin 的脚本发送电子邮件，它可以选择从 B 列值发送电子邮件地址。

我从 B 列到 E 列至少有 4 列电子邮件地址。如何修改它以发送这封电子邮件？

例子：

在 Sheets("Sheet1") 中使用：

• 在 A 列中：人名
• 在 B 列中：电子邮件地址
• 在 C:Z 列中：文件名如下：C:\Data\Book2.xls（不必是 Excel 文件）

宏将循环遍历Sheet1 中的每一行，如果 B 列中有电子邮件地址，C:Z 列中有文件名，它将创建包含此信息的邮件并发送。

Sub Send_Files()
'Working in Excel 2000-2013
'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

Answer 1

大量编辑

根据您的评论，以下代码已更改。应该在列F 中有一个文件名的假设下工作。删除/注释掉的行在下面的代码中标出，以防您不想要这个要求。

Private Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'--BK201 mod: http://stackoverflow.com/questions/20776481/send-mail-with-email-address-in-4-columns--'

Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet
Dim FileCell As Range
Dim Rec As Range, RecRng As Range, RecList As Range, RecMail As Range
Dim FileRng As Range
Dim RecStr As String

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

Set Sh = ThisWorkbook.Sheets("Sheet1")
Set RecList = Sh.Range("B:B")
Set OutApp = CreateObject("Outlook.Application")

For Each Rec In RecList

    With Sh
        Set RecRng = .Range("B" & Rec.Row & ":E" & Rec.Row)
        Set FileRng = .Range("F" & Rec.Row)
    End With

    RecStr = ""
    For Each RecMail In RecRng
        If RecMail.Value Like "?*@?*.?*" Then
            RecStr = RecStr & RecMail.Value & ";"
        End If
    Next RecMail

    If Len(FileRng.Value) > 0 Then '--Comment out if alright to send without attachment.
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .to = RecStr
            .Subject = "Testfile"
            .Body = "Hi " & Rec.Offset(0, -1).Value

            On Error Resume Next
            For Each FileCell In FileRng
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell
            .Display '.Send
        End With
        Set OutMail = Nothing
    Else '--Comment out if alright to send without attachment.
        Exit For '--Comment out if alright to send without attachment.
    End If '--Comment out if alright to send without attachment.

Next Rec

Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

设置：

结果：

希望这会有所帮助。 :)