need a macro that will send an email or emails from a list of emails

Column A = persons name
column B = persons email address
Column C = date email needs to be sent
Column D = has email already been sent Y/N

Can optionally create column E if it makes this macro easier = Does an email need to be sent today Y/N

I will have a macro that continuously adds new addresses to the bottom of this list, it will also populate the date column at this point

I want a macro that I can run daily that will check Columns C&D (or E) and send an email to that person if the date in column C is today (or earlier) AND the person hasn't already had an email sent to them.
So the macro needs to also update Column D for each email it sends, might be helpful to have it add the date the email was sent in Column F as well.

The macro can either email each person individually or BCC them all on to one email, I don't expect much more than 10-15 email addresses per day.

Here you go

Option Explicit

Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error GoTo erHandle
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
      If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
      Sheet1.Cells(i, "D").Value = "Bad Email"
      GoTo skip
      End If
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        If (IsEmpty(Cells(i, "D").Value) Or Cells(i, "D").Value = "N") _
        And Sheet1.Cells(i, "C").Value <= Date Then 'Check for date
        With OutMail
            .To = Sheet1.Cells(i, "B").Value
            .CC = ""
            .Subject = "Enter Subject here" '& Sheet1.Cells(i, "B")
            .HTMLBody = "Dear " & Cells(i, "A") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            '.Attachments.Add
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Sheet1.Cells(i, "E").Value = Date
        Sheet1.Cells(i, "D").Value = "Y"
        Set OutMail = Nothing
        Set OutApp = Nothing
        End If
skip:
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function

Thanks,

what criteria does the code use to determine if a cell is not an email ?

I have tested this and purposely missed the ".co.uk" off the test email I was using, the macro runs ok when using .display. (doesn't flag the mail as bad)
However when I switch to .Send those bad emails create an error and trigger the error handler.

Error #-2147467259
Outlook does not recognise one or more names.

The process to check emails was written by one of the gurus here. It definitely is not foolproof, as you have found.

Originally Posted by maniacb

The process to check emails was written by one of the gurus here. It definitely is not foolproof, as you have found.

Is there anything that can be done in this case to have it ignore the error ?
I am guessing not as its essentially an outlook error.

I have put further checks in, earlier in the process to try and prevent bad email addresses making it through but that will not be infallible.

Try this approach. Instead of notifying you of the error in VBA, this process will just continue sending emails, but you won't know that their is a bad email if the internal check doesn't catch the error. I'm assuming the email error you received is generated through VBA, but if it is generated by Outlook, we may be out of luck.

Option Explicit

Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
      If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
        Sheet1.Cells(i, "D").Value = "Bad Email"
        GoTo skip
      End If
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        If (IsEmpty(Cells(i, "D").Value) Or Cells(i, "D").Value = "N") _
        And Sheet1.Cells(i, "C").Value <= Date Then 'Check for date
        With OutMail
            .To = Sheet1.Cells(i, "B").Value
            .CC = ""
            .Subject = "Enter Subject here" '& Sheet1.Cells(i, "B")
            .HTMLBody = "Dear " & Cells(i, "A") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            '.Attachments.Add
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Sheet1.Cells(i, "E").Value = Date
        Sheet1.Cells(i, "D").Value = "Y"
        Set OutMail = Nothing
        Set OutApp = Nothing
        End If
skip:
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function

Originally Posted by maniacb

Try this approach. Instead of notifying you of the error in VBA, this process will just continue sending emails, but you won't know that their is a bad email if the internal check doesn't catch the error. I'm assuming the email error you received is generated through VBA, but if it is generated by Outlook, we may be out of luck.

SNIP

This does exactly what you said.
If I check the sent items the bad email does not show as a sent item, and it does not get flagged in excel.

I assume from your post that there is no way to work around this ?


Regards
James

It sounds like the VBA produced the error code. Let's try the following approach to annotate the bad email in your spreadsheet.

Sub emailattachpdffile()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim i As Integer
    Dim lr As Integer
    Dim Path As String

    Application.ScreenUpdating = False
    
    lr = Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
    On Error Resume Next
    For i = 2 To Sheet1.Cells(Rows.Count, "B").End(xlUp).Row
      If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
        Sheet1.Cells(i, "D").Value = "Bad Email"
        GoTo skip
      End If
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        If (IsEmpty(Cells(i, "D").Value) Or Cells(i, "D").Value = "N") _
        And Sheet1.Cells(i, "C").Value <= Date Then 'Check for date
        With OutMail
            .To = Sheet1.Cells(i, "B").Value
            If Err.Number <> 0 Then
                Sheet1.Cells(i, "D").Value = "Bad Email"
                On Error GoTo -1
                GoTo skip
            End If
            .CC = ""
            .Subject = "Enter Subject here" '& Sheet1.Cells(i, "B")
            .HTMLBody = "Dear " & Cells(i, "A") & "," & Chr(11) & Chr(11) & "Please find the full Final Settlement." & Chr(11) & Chr(11) & "Thanks and Regards" & Chr(11) & Chr(11) & .HTMLBody
            '.Attachments.Add
            .Display    'DELETE THIS LINE IF USING SEND
            '.send
        End With
        Sheet1.Cells(i, "E").Value = Date
        Sheet1.Cells(i, "D").Value = "Y"
        Set OutMail = Nothing
        Set OutApp = Nothing
        End If
skip:
    Next i
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
End Sub

Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function

That produces the same result.