在 vba 中的循环功能中需要帮助以发送多封电子邮件

Question

我有一个 Excel VBA (Send_Mail) 通过 Lotus Notes 发送电子邮件。它工作正常，但是我需要帮助才能一次性将个人电子邮件发送给多个人。

在我的 Excel 表格中。向下的单元格 A7 将是最多可以超过 200 行的电子邮件地址，B7 具有主题行，单元格 C7 具有电子邮件正文。 （所有这些都使用不同的宏自动填充）。但是，我的代码（Send_Mail）只是向单元格 A7 中的地址发送一封电子邮件。我需要您的帮助，以便将邮件发送到 Col A7 及以后的所有电子邮件地址，并附上其各自的主题 (Col B) 和邮件正文 (col 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

我担心有太多新细节让您感到困惑，并且必须承认我没有测试过以下代码，所以请不要以为这会彻底解决您的问题。

以下内容让您了解如何按照您的要求使用循环。另请参阅示例here，它涵盖了您可能需要批量发送的实例（诚然链接适用于 Outlook），也是使用循环的示例。

我在代码中包含了一些解释。如果没有更多信息，很难正确调整它，但我希望它有所帮助。

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)

宏将遍历“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

查看此链接了解所有详情。

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