Question

我已经整理了这段代码，但可悲的是，我似乎无法解决如何在BCC中仅保留过期条目的电子邮件地址的问题。

我希望它从到期日期已过期且尚未发送前一封电子邮件的电子邮件列表中创建到多个电子邮件地址的单个电子邮件。

Sub Over_due()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lLastRow As Long
    Dim lRow As Long
    Dim rng As Range
    
    strbody = "Text goes here"
    
    lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
    For lRow = 2 To lLastRow
        If Cells(lRow, 6) <> "Email Sent" Then
            If Cells(lRow, 5) <= Date Then
            
            Set xOutlook = CreateObject("Outlook.Application")
            Set xMailItem = xOutlook.CreateItem(0)
                                
    For Each rng In Range("C:C")
        If rng.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = rng.Value
            Else
                xEmailAddr = xEmailAddr & ";" & rng.Value
            End If
        End If
     Next
     
    On Error Resume Next
               With xMailItem
        .To = ""
        .CC = ""
        .BCC = xEmailAddr
        .Subject = Range("A1").Value
        .HTMLBody = strbody
        '.Attachments.Add
        .Display
        End With
        MsgBox "E-mail successfully created", 64
        Application.DisplayAlerts = False
        Set Mail_Object = Nothing

                Cells(lRow, 6) = "Sent email"
                Cells(lRow, 7) = "" & Now()
            End If
        
        
        
        End If
    Next
    Set OutApp = Nothing
End Sub

Answer 1

我使用一个自动创建电子邮件的子项。并从其他各种子菜单中调用它-可能会派上用场

Sub SendEmail(Optional ToAddresses As String, Optional CcAddresses As String, _
Optional BccAddresses As String, Optional Subject As String, _
Optional Body As String, Optional AttachFiles As Variant = False, Optional AutoSend As Boolean = False)

'RULES:
'    Where there are multiple Addresses in ToAddresses, CCAddresses 
'      etc, they have to be separated by a semicolon
'    AttachFiles should either be a string containing the full 
'      filename including the path, or (for multiple files) an array 
'      of same.
'    Body can be HTML or just plain text.

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .to = ToAddresses
        .CC = CcAddresses
        .Bcc = BccAddresses
        .Subject = Subject
        
        If Body Like "*</*>*" Then
            .HtmlBody = Body
        Else
            .Body = Body
        End If
        
        If Not AttachFiles = False Then
            If IsArray(AttachFiles) Then
                For x = LBound(AttachFiles) To UBound(AttachFiles)
                    .Attachments.Add (AttachFiles(x))
                Next
            Else
                .Attachments.Add (AttachFiles)
            End If
        End If
        
        If AutoSend = True Then
            .Send
        Else
            .Display
        End If
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

这不完全是我的代码，我改编自here。它不会完全解决您的问题，但可能会将其浓缩为更简单，更类似的内容：

Sub OverDue()
Dim strBody as String
Dim Row as Long
Dim lLastRow as Long

StrBody = "Text here"

lLastRow = UsedRange.Rows.Count 

For a = 2 to lLastRow
    If Cells(a, 6) <> "Email Sent" And Cells(a, 5)<= Date Then 'This checks each row to see if that person needs an email
'        DO STUFF HERE
'        Either Call the other sub separately each time 
'        (which can allow for more personalised messages, like a mail merge), 
'        or add the person's email address to a string and call the sub
'        after the loop.
Next

End Sub

由您来解决其余细节！

Answer 2

我这样修改了您的代码

    Sub Over_due()
        Dim OutApp As Object
        Dim OutMail As Object
        Dim lLastRow As Long
        Dim lRow As Long
        Dim rng As Range
        
        Dim strbody As String
        Dim xOutlook
        Dim xMailItem
        Dim xEmailAddr
        
        
        strbody = "Text goes here"
        
        lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
        For lRow = 2 To lLastRow
            If Cells(lRow, 6) <> "Email Sent" Then
                If Cells(lRow, 5) <= Date Then
                
                    Set xOutlook = CreateObject("Outlook.Application")
                    Set xMailItem = xOutlook.CreateItem(0)
                                    
    '                For Each rng In Range("C:C")
    '                    If rng.Value Like "*@*" Then
    '                        If xEmailAddr = "" Then
    '                            xEmailAddr = rng.Value
    '                        Else
    '                            xEmailAddr = xEmailAddr & ";" & rng.Value
    '                        End If
    '                    End If
    '                Next

    'Do you really want to have all emails addresses in BCC because thats what you are doing
    'I changed the above code to the following lines which will not take the complete column 
                    Set rng = Range("C2:C" & lRow)
                    xEmailAddr = Join(WorksheetFunction.Transpose(rng), ",")
         
                    On Error Resume Next
                    With xMailItem
                        .To = ""
                        .CC = ""
                        .BCC = xEmailAddr
                        .Subject = Range("A1").Value
                        .HTMLBody = strbody
                        '.Attachments.Add
                        .Display
                    End With
                    MsgBox "E-mail successfully created", 64
                    Application.DisplayAlerts = False
                    ' I changed that to Email Sent otherwise it will create the mai over and over again
                    Cells(lRow, 6) = "Email Sent"
                    Cells(lRow, 7) = "" & Now()
                End If
            
            
            
            End If
        Next
        Set OutApp = Nothing
    End Sub

根据单元格值发送自动电子邮件

2 个答案: