发送给所有或指定收件人的列表框选项

Question

我浏览了一些帖子，但没有帮助。

我的代码将相同的电子邮件合并为一封电子邮件，还合并了 table。如果我要发送给所有人就可以了。

Sub SendEmail()
    OptimizedMode True
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim dict As Object 'keep the unique list of emails
    Dim cell As Range
    Dim cell2 As Range
    Dim Rng As Range
    Dim i As Long
    Dim ws As Worksheet
    Dim Signature As String
    
    Set OutApp = CreateObject("Outlook.Application")
    Set dict = CreateObject("scripting.dictionary")
    Set ws = ThisWorkbook.Sheets("Table") 'Current worksheet name
    
    On Error GoTo cleanup
    For Each cell In ws.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
    
            'check if this email address has been used to generate an outlook email or not
            If dict.exists(cell.Value) = False Then
    
                dict.Add cell.Value, "" 'add the new email address
                Set OutMail = OutApp.CreateItem(0)
                Set Rng = ws.UsedRange.Rows(1)
    
                'find all of the rows with the same email and add it to the range
                For Each cell2 In ws.UsedRange.Columns(1).Cells
                    If cell2.Value = cell.Value Then
                        Set Rng = Application.Union(Rng, ws.UsedRange.Rows(cell2.Row))
                    End If
                        
                    With ws.UsedRange
                        Set Rng = Intersect(Rng, .Columns(2).Resize(, .Columns.Count - 1))
                    End With
                Next cell2
    
                On Error Resume Next
                With OutMail
                    .SentOnBehalfOfName = "email@email"
                    .GetInspector ' ## This inserts default signature
                    Signature = .HTMLBody ' ## Capture the signature HTML
                    .To = cell.Value
                    .CC = "email@test.com"
                    .Subject = "Reminder"
                    .HTMLBody = "test"
                        
                    If UserForm1.OptionButton1.Value = True Then
                        .Send
                    Else
                        .Display
                    End If
                End With
                On Error GoTo 0
                
                Set OutMail = Nothing
            End If
        End If
    Next cell
    
cleanup:
    Set OutApp = Nothing
    AppActivate UserForm1.Caption
    Dim OutPut As Integer
    OutPut = MsgBox("Successfully Completed Task.", vbInformation, "Completed")
        
    OptimizedMode False
End Sub

我想要列表框上的“全部发送”或“发送至所选”选项。

此外，如果 sub 检测到空白或“未找到”，我该如何退出？

Private Sub CommandButton3_Click()
    If ButtonOneClick Then
         GoTo continue
    Else
        MsgBox "Please Generate Table.", vbCritical
        Exit Sub
    End If
    ButtonOneClick = False
    
continue:
    Dim Wb As Workbook
    Dim ws As Worksheet
    Dim rng1 As Range
    Set Wb = ThisWorkbook
    Set ws = Wb.Sheets("Table")
    'find not found or any blanks...
    Set rng1 = ws.Range("A:A").Find("Not Found", ws.[a1], xlValues, xlWhole, , xlNext)
    If Not rng1 Is Nothing Then
        MsgBox "ERROR. Check E-mails in Table.", vbCritical
    Else
        Call SendEmail
        CommandButton3.Enabled = False
    End If
End Sub

我怎样才能合并这样的东西？

For i = 0 To Me.ListBox1.ListCount - 1
    With Me.ListBox1
        If Me.opt_All.Value = True Then
            Call SendEmail
        Else
            If .Selected(i) Then
                call SendEmail
            End If
        End If
    End With
Next i

Answer 1

将您的脚本分成 3 个部分。首先建立邮件列表。然后为每个地址确定范围并发送电子邮件。

用 MEmail.CreateMailList 替换 continue: 之后的代码，并使用此代码

添加一个名为 MEmail 的模块

Option Explicit

Sub CreateMailList()

    Dim MailList
    Set MailList = CreateObject("Scripting.Dictionary")

    ' build email list
    Dim i As Integer, rng As Range, addr
    With UserForm1.ListBox1

        ' scan table building ranges
        For i = 0 To .ListCount - 1
            If .Selected(i) Or UserForm1.OptionButton3.Value = True Then
                
                addr = Trim(.List(i, 0)) ' email address
                If Len(addr) > 0 Then
                    If Not MailList.exists(addr) Then
                        Set rng = Sheets("Table").Cells(1, 2).Resize(1, .ColumnCount-1)
                        MailList.Add addr, rng
                    End If

                    Set rng = Sheets("Table").Cells(i + 2, 2).Resize(1, .ColumnCount-1)
                    Set MailList(addr) = Union(MailList(addr), rng)
                End If

            End If
        Next i
    End With

    If MailList.Count = 0 Then
        MsgBox "No rows selected", vbExclamation
    Else
        If MsgBox("Do you want to send " & MailList.Count & " emails", vbYesNo) = vbYes Then
            SendEmails MailList
        End If
    End If

End Sub

Sub SendEmails(ByRef MailList)
    'OptimizedMode True
    
    Dim OutApp, addr
    
    ' send email
    Set OutApp = CreateObject("Outlook.Application")
    For Each addr In MailList
        SendOneEmail OutApp, CStr(addr), MailList.item(addr)
    Next
     
    Set OutApp = Nothing
    'AppActivate UserForm1.Caption
    MsgBox "Successfully Completed", vbInformation, "Completed Emails Sent=" & MailList.Count
        
    'OptimizedMode False
End Sub

Sub SendOneEmail(OutApp, EmailAddress As String, rng As Range)

    Dim OutMail, Signature As String
    Set OutMail = OutApp.CreateItem(0)

    ' email
    With OutMail
        .SentOnBehalfOfName = "email@email"
        .GetInspector ' ## This inserts default signature
        Signature = .HTMLBody ' ## Capture the signature HTML
        .To = EmailAddress
        .CC = "email@test.com"
        .Subject = "Reminder"
        .HTMLBody = "<BODY style=font-size:12pt;font-family:Calibri><font color=#000000>Hi " _
                   & WorksheetFunction.Proper(RemoveNumbers(Left((EmailAddress), InStr((EmailAddress), ".") - 1))) & ", " & _
                    "<br><br>" & "Please see your trip numbers and estimated cost below:" & _
                   vbNewLine & vbNewLine & RangetoHTML(rng) & Signature & "</font></BODY>"

        If UserForm1.OptionButton1.Value = True Then
           ' .Send
        Else
            .Display
        End If
    End With
    Set OutMail = Nothing
    
End Sub

发送给所有或指定收件人的列表框选项

Listbox option to send to all or specified recipients

excel

vba

userform