如果选中复选框，则发送电子邮件

Question

您好，我想将电子邮件发送到选中的地址 我有：

1. 复选框
2. 列名

3. 列电子邮件

   Sub reminder1()
   
   Dim lRow As Integer
   Dim i As Integer
   Dim toList As String
   Dim eSubject As String
   Dim eBody As String
   
   With Application
       .ScreenUpdating = False
       .EnableEvents = False
       .DisplayAlerts = False
   End With
   
   Sheets(1).Select
   lRow = Cells(Rows.Count, 4).End(xlUp).Row
   
   For i = 2 To lRow
   
       If Sheets("Sheet1").CheckBox1.Value = True Then
   
           Set OutApp = CreateObject("Outlook.Application")
           Set OutMail = OutApp.CreateItem(0)
           Cells(i, 5) = "Mail Sent " & Date + Time
           Cells(i, 5).Font.Bold = True
   
           toList = Cells(i, 3)
   
           eSubject = "Your "
   
           eBody = "Good Day"
   
           On Error Resume Next
   
           With OutMail
               .To = toList
               .CC = ""
               .BCC = ""
               .Subject = eSubject
               .BodyFormat = olFormatHTML
               .Display
               .HTMLBody = eBody & vbCrLf & .HTMLBody
               '.Send
           End With
   
           On Error GoTo 0
           Set OutMail = Nothing
           Set OutApp = Nothing 
       End If
       Next i
   
       ActiveWorkbook.Save
   
       With Application
           .ScreenUpdating = True
           .EnableEvents = True
           .DisplayAlerts = True
       End With
   End Sub
   

问题是，如果我选中第一个，它会向所有人发送电子邮件，如果未选中，即使选中其他复选框也不会发送电子邮件

Answer 1

您需要遍历复选框。您当前的代码被硬编码为只检查第一个复选框，即“CheckBox1”。

代替：

If Sheets("Sheet1").CheckBox1.Value = True Then
'code
end if

使用如下内容：

If ActiveSheet.OLEObjects("Checkbox"&i-1).Object.Value  = True Then
'code
End If

替代方案 而不是复选框，使用带有 true / false 的下拉菜单 然后使用这样的东西：

if cells(i,1).value = True then
'code
end if

Answer 2

我建议您遍历所有复选框并尝试找到适用于您当前所在行的复选框。因此，为了坚持您的解决方案并在每一行中都有一个复选框，您需要验证哪个复选框适用于您所在的行，并查看该复选框是否被选中。

Sub reminder1()

Dim lRow As Integer
Dim i As Integer
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim oleControl As OLEObject

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

Sheets(1).Select
lRow = Cells(Rows.Count, 4).End(xlUp).Row

For i = 2 To lRow
    For Each oleControl In Sheets("Sheet1").OLEObjects
        If Range(oleControl.TopLeftCell.Address).Row = i Then
            If oleControl.Object.Value = True Then

                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                Cells(i, 5) = "Mail Sent " & Date + Time
                Cells(i, 5).Font.Bold = True

                toList = Cells(i, 3)

                eSubject = "Your "

                eBody = "Good Day"

                On Error Resume Next

                With OutMail
                    .To = toList
                    .CC = ""
                    .BCC = ""
                    .Subject = eSubject
                    .BodyFormat = olFormatHTML
                    .Display
                    .HTMLBody = eBody & vbCrLf & .HTMLBody
                    '.Send
                End With

                On Error GoTo 0
                Set OutMail = Nothing
                Set OutApp = Nothing

            End If
        End If
    Next oleControl 
Next i

ActiveWorkbook.Save

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With

End Sub

请注意，此代码假定复选框的左上角位于复选框所适用的行内。如果不是这种情况，那么您也可以使用.BottomRightCell.Address 或两者的混合。 另请注意，此代码不会验证工作表上是否还有其他形状，例如组合框或按钮或其他东西。