Question

您好我想将电子邮件发送到已检查的地址我有：

复选框
列名

列电子邮件

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或两者的混合。另请注意，此代码不会验证工作表上是否有其他形状，例如组合框或按钮或其他内容。

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

2 个答案: