複数の電子メール送信者 - すべてのメールアドレスが1つ以上のメッセージを受信します

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で行うことができます。

とシート（ "シート1"）でリストを作成します：列Aで

：列Bの人の名前：コラムCではE-mailアドレス：Z：このCのようなファイル名：\データ\ Book2.xls（Excelファイルである必要はありません）

マクロは "Sheet1"の各行をループし、列Bに電子メールアドレスがあり、列Cにファイル名がある場合は、 Zはこの情報でメールを作成して送信します。

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