Question

我正在开发一个向多个电子邮件地址发送电子邮件的程序。问题是，当我发送消息时，每个邮件地址都会收到多条消息。如果我有5个电子邮件地址，程序会向每个电子邮件地址发送5封邮件。我怎么解决这个问题？这是我的代码：

Private Sub button1_Click(sender As Object, e As EventArgs) Handles button1.Click
    Dim trd As Threading.Thread
    trd = New Threading.Thread(AddressOf mailBomber)
    trd.isBackground = True
    trd.Start()
End Sub

Private Function mailBomber()
    Dim sent As Integer = 0
    Dim toSend As Integer = 5
    Do Until sent >= toSend
        Try
            Dim SmtpServer As New SmtpClient()
            Dim mail As New MailMessage()
            SmtpServer.Credentials = New Net.NetworkCredential(emailFrom.Text, emailPass.Text)
            SmtpServer.EnableSsl = True
            SmtpServer.Port = 587
            SmtpServer.Host = "smtp.gmail.com"
            mail = New MailMessage()
            mail.From = New MailAddress(emailFrom.Text)
            mail.To.Add(emailTo.Text)
            mail.Subject = subject.Text
            mail.Body = msg.Text
            SmtpServer.Send(mail)
            sent += 1
        Catch ex As Exception
            MsgBox(ex.ToString)
        End Try
    Loop
End Function

Answer 1

您可以使用以下概念使用VBA进行此操作。

在Sheets（“Sheet1”）中创建一个列表：

在A栏中：人物的名字在B栏中：电子邮件地址在C栏中：Z：像这样的文件名C：\ Data \ Book2.xls（不一定是Excel文件）

宏将循环遍历“Sheet1”中的每一行，如果列B中有电子邮件地址，列C：Z中有文件名，则会创建包含此信息的邮件并发送。< / p>

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

多个电子邮件发件人 - 每个邮件地址都会收到多条邮件

1 个答案: