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

设置向上：

<强>结果：

希望这会有所帮助。：）

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

1 个答案: