複数の電子メールを送信するためのvbaのループ機能のヘルプが必要

Question

私は、Lotus Notesを介して電子メールを送信するためのExcel VBA（Send_Mail）を持っています。それはうまくいっていますが、私は一人で複数の人に個別のメールを送る際に助けが必要です。

私のExcelシートにあります。セルA7は200行以上になる電子メールアドレス、B7は件名、Cell C7はメール本文を持ちます。 （これには別のマクロが自動的に入力されています）。しかし、私のコード（Send_Mail）は、セルA7にあるアドレスにただ1つの電子メールを送信しています。私はCol A7以降のメールアドレス宛てに、それぞれの件名（Col B）とメール本文（C C）をメールで送信してください。

以下は私のコードです。

Public TOID As String 
Public CCID As String 
Public SECT As String 
Public ACCO As String 
Public SUBJ As String 

Sub Send_Mail() 

Dim answer As Integer 

answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES") 

If answer = vbNo Then 
    MsgBox "Please Open Notes and Try the Macro Again" 
    Exit Sub 

Else 

End If 

Application.DisplayAlerts = False 

Call Send 

MsgBox "Mail Sent to " & (Range("L2").Value) & " " & "Recipents" 

Application.DisplayAlerts = True 

End Sub 

Public Function Send() 

    SendEMail = True 

    Sheets("Main").Select 

    TOID = Range("A7").Value 
    CCID = "" 
    SUBJ = Range("B7").Value 
    'On Error GoTo ErrorMsg 

    Dim EmailList As Variant 
    Dim ws, uidoc, Session, db, uidb, NotesAttach, NotesDoc, objShell As Object 
    Dim RichTextBody, RichTextAttachment As Object 
    Dim server, mailfile, user, usersig As String 
    Dim SubjectTxt, MsgTxt As String 

    Set Session = CreateObject("Notes.NotesSession") 
    user = Session.UserName 
    usersig = Session.COMMONUSERNAME 
    mailfile = Session.GETENVIRONMENTSTRING("MailFile", True) 
    server = Session.GETENVIRONMENTSTRING("MailServer", True) 

    Set db = Session.GETDATABASE(server, mailfile) 

    If Not db.IsOpen Then 
     Call db.Open("", "") 
     Exit Function 
    End If 

    Set NotesDoc = db.CREATEDOCUMENT 

    With NotesDoc 
     .Form = "Memo" 
     .Subject = SUBJ       'The subject line in the email 
     .Principal = user 
     .sendto = TOID       'e-mail ID variable to identify whom email need to be sent 
     .CopyTo = CCID 
    End With 

    Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body") 

    With NotesDoc 
     .COMPUTEWITHFORM False, False 
    End With 

    '==Now set the front end stuff 
    Set ws = CreateObject("Notes.NotesUIWorkspace") 

    If Not ws Is Nothing Then 

     Set uidoc = ws.EDITDOCUMENT(True, NotesDoc) 

     If Not uidoc Is Nothing Then 

      If uidoc.EDITMODE Then 

       'Mail Body 
       Sheets("Main").Select 
       Range("C7").Select 
       Dim rnBody1 As Range 
       Set rnBody1 = Selection 
       rnBody1.CopyPicture 

       'rnBody1.Copy 
       Call uidoc.GOTOFIELD("Body") 
       Call uidoc.Paste 
      End If 

     End If 

    End If 

    Call uidoc.Send 
    Call uidoc.Close 

    'close connection to free memory 
    Set Session = Nothing 
    Set db = Nothing 
    Set NotesAttach = Nothing 
    Set NotesDoc = Nothing 
    Set uidoc = Nothing 
    Set ws = Nothing 

    Sheets("Main").Select 

End Function 

Answer 1

私はあまり新しいディテールであなたを混乱心配と私は、これは完全にあなたの問題を解決すると仮定しないでください、次のコードをテストしていないと公言しなければなりません。

以下は、要求どおりにループを使用する方法を示しています。また、バッチ送信が必要な場合（おそらくOutlook用のリンク）と、ループの使用例をカバーする例も参照してください。hereを参照してください。

私はコードの途中にいくつかの説明を入れました。これを適切に調整するための情報がなければ難しいですが、それが助けてくれることを願っています。

Option Explicit 

Public TOID As String 
Public CCID As String 
Public SECT As String 
Public ACCO As String 
Public SUBJ As String 

Public Sub Send_Mail() 

Dim wb As Workbook 
Dim ws1 As Worksheet 

Set wb = ThisWorkbook 'These are assumptions 
Set ws1 = wb.Worksheets("Sheet1") 'These are assumptions. You would change as necessary 

Dim answer As Long 'Integer types changed to Long 

answer = MsgBox("DO YOU HAVE LOTUS NOTES OPEN ?? Not WebLotus notes", vbYesNo + vbQuestion, "LOTUS NOTES") 

If answer = vbNo Then 
    MsgBox "Please Open Notes and Try the Macro Again" 
    Exit Sub 

'Else 'Not being used so consider removing 

End If 

Application.DisplayAlerts = False 

Dim lRow As Long 
Dim loopRange As Range 
Dim currentRow As Long 
Dim TOIDvar As String 
Dim SUBJvar As String 

With ws1 

    lRow = .Range("A7").End(xlDown).Row 'Assume no gaps in column A in the TOID range 
    Set loopRange = .Range("A7:A" & lRow) 

    For currentRow = 1 To loopRange.Rows.Count 'Loop range assigning values to arguments and call send sub with args 

     TOIDvar = loopRange.Cells(currentRow, 1) 

     SUBJvar = loopRange.Cells(currentRow, 1).Offset(0, 1) ' get column B in same row using Offset 

     Send TOIDvar, SUBJvar 

    Next currentRow 


End With 


'Commented out MsgBox at present as unsure what you will do when sending multiple e-mails 
'MsgBox "Mail Sent to " & (ws1.Range("L2").Value) & " " & "Recipents" 'use explicit fully qualified Range references 

Application.DisplayAlerts = True 

End Sub 

Public Sub Send(ByVal TOIDvar As String, ByVal SUBJvar As String) 'changed to sub using arguments 

    Dim SendEMail As Boolean 'declare with type 
    Dim wb As Workbook 
    Dim ws2 As Worksheet 

    Set wb = ThisWorkbook 'These are assumptions. Ensuring you are working with correct workbook 
    Set ws2 = wb.Worksheets("Main") 

    SendEMail = True 
    TOID = TOIDvar 
    CCID = vbNullString 'use VBNullString rather than empty string literals 
    SUBJ = SUBJvar 
    'On Error GoTo ErrorMsg 

    Dim EmailList As Variant 'declaration of separate lines and with their types 
    Dim ws As Object 
    Dim uidoc As Object 
    Dim Session As Object 
    Dim db As Object 
    Dim uidb As Object 
    Dim NotesAttach As Object 
    Dim NotesDoc As Object 
    Dim objShell As Object 
    Dim RichTextBody As Object 
    Dim RichTextAttachment As Object 
    Dim server As String 
    Dim mailfile As String 
    Dim user As String 
    Dim usersig As String 
    Dim SubjectTxt As String 
    Dim MsgTxt As String 

    Set Session = CreateObject("Notes.NotesSession") 
    user = Session.UserName 
    usersig = Session.COMMONUSERNAME 
    mailfile = Session.GETENVIRONMENTSTRING("MailFile", True) 
    server = Session.GETENVIRONMENTSTRING("MailServer", True) 

    Set db = Session.GETDATABASE(server, mailfile) 

    If Not db.IsOpen Then 
     db.Open vbNullString, vbNullString 
     Exit Sub 
    End If 

    Set NotesDoc = db.CREATEDOCUMENT 

    With NotesDoc 
     .Form = "Memo" 
     .Subject = SUBJ       'The subject line in the email 
     .Principal = user 
     .sendto = TOID       'e-mail ID variable to identify whom email need to be sent 
     .CopyTo = CCID 
    End With 

    Set RichTextBody = NotesDoc.CREATERICHTEXTITEM("Body") 

    With NotesDoc 
     .COMPUTEWITHFORM False, False 
    End With 

    '==Now set the front end stuff 
    Set ws = CreateObject("Notes.NotesUIWorkspace") 

    If Not ws Is Nothing Then 

     Set uidoc = ws.EDITDOCUMENT(True, NotesDoc) 

     If Not uidoc Is Nothing Then 

      If uidoc.EDITMODE Then 

       'Mail Body 
       With ws2.Range("C7") 
        Dim rnBody1 As Range 
        Set rnBody1 = .Value2 
        rnBody1.CopyPicture 

       'rnBody1.Copy 
        uidoc.GOTOFIELD "Body" 
        uidoc.Paste 
       End With 

      End If 

     End If 

    End If 

    uidoc.Send 
    uidoc.Close 

    'removed garbage collection 

    ws2.Activate ' swopped out .Select and used Worksheets collection held in variable ws2 

End Sub 

Answer 2

これは考慮する必要があります。

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) 

「シート1」の各行を介してマクロ意志ループ及び列Cの列B とファイル名（複数可）におけるE-mailアドレスがある場合：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 

すべての詳細については、このリンクを参照してください。

https://www.rondebruin.nl/win/s1/outlook/amail6.htm