Automated emails based on Expiry date of different machines

[Oscarsalone]

Hi guys,

I need help creating a code that send and email based on the expiry date of different machines. The main problem I am having is including all the expired machines into one email, as opposed to multiple emails. The excel sheet that includes expiration date in column "I", the name of the machine in column "B", and has a function that calculates if my machines are "calibrated", "expired", or "near expiration", this is in column P.
Here is the code I have so far:

Private Sub Workbook_Open()
  Dim Instrument As String
  Dim Status As String

  Status = Range("P6").Value
    If IsNull(Status) = True Then Exit Sub

    If Status = "Expiring Soon" Then
        Instrument = Range("B6").Value
        Mail_Expiring_Soon_Outlook Instrument
    End If

    If Status = "Expired" Then
        Instrument = Range("B6").Value
        Mail_Expired_Outlook Instrument
    End If
End Sub


Sub Mail_Expiring_Soon_Outlook(Instrument As String)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Attention" & vbNewLine & vbNewLine & _
              "The " & Instrument & " calibration is due within 30 days." & vbNewLine & vbNewLine & _
              "Please arrange calibration."
    On Error Resume Next
    With xOutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Calibration Due within 30 days"
        .Body = xMailBody
        .Display  
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub


Sub Mail_Expired_Outlook(Instrument As String)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Warning!" & vbNewLine & vbNewLine & _
              "The " & Instrument & " calibration is expired." & vbNewLine & vbNewLine & _
              "Please arrange calibration."
    On Error Resume Next
    With xOutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "Warning! Calibration is Expired"
        .Body = xMailBody
        .Display  
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

 

[GWteB]

Hi Oscarsalone, welcome to Mr. Excel.
The code below lists the affected machines in a table. This table is then pasted into the body of the email.
The code assumes that row 1 contains headers, data from row 2 and downwards.
You may be able to do something with this approach.

Public Sub Example()

    Dim oWs     As Worksheet
    Dim sStatus As String

    Application.ScreenUpdating = False
    Set oWs = ThisWorkbook.Sheets("Sheet1")     ' << change as required
    
    sStatus = "Expired"
    Call Mail_Outlook(oWs, sStatus)

    sStatus = "Near expiration"
    Call Mail_Outlook(oWs, sStatus)
    Application.ScreenUpdating = True
End Sub


Public Sub Mail_Outlook(ByVal argSourceSheet As Worksheet, ByVal argStatus As String)

    Const cBody_Exp As String = "Warning!" & vbNewLine & vbNewLine & "Calibration of the instruments listed below has expired."
    Const cBody_Near As String = "Attention" & vbNewLine & vbNewLine & "Calibration of the instruments listed below expires within 30 days."

    Const cSubj_Exp As String = "Warning! Calibration has expired"
    Const cSubj_Near As String = "Calibration expires within 30 days"

    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody_Start As String
    Dim xMailBody_End   As String
    Dim sSubject        As String
    Dim oWs             As Worksheet
    Dim oDoc            As Object
    Dim i               As Long

    If StrComp(argStatus, "EXPIRED", vbTextCompare) = 0 Then
        sSubject = cSubj_Exp
        xMailBody_Start = cBody_Exp
    ElseIf StrComp(argStatus, "NEAR EXPIRATION", vbTextCompare) = 0 Then
        sSubject = cSubj_Near
        xMailBody_Start = cBody_Near
    Else
        ' do nothing
    End If
    xMailBody_End = "Please arrange calibration." & vbNewLine & vbNewLine & _
                    "Regards,"

    Set oWs = Workbooks.Add.ActiveSheet
    With oWs
        argSourceSheet.Columns("B:B").Copy .Columns(1)
        argSourceSheet.Columns("I:I").Copy .Columns(2)
        argSourceSheet.Columns("P:P").Copy .Columns(3)
        For i = .UsedRange.Rows.Count To 2 Step -1
            If Not StrComp(.Cells(i, 3), argStatus, vbTextCompare) = 0 Then
                .Cells(i, 3).EntireRow.Delete
            End If
        Next i
        .Columns.AutoFit
    End With
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    With xOutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = sSubject
        
        ' compose email body
        .Display
        Set oDoc = .GetInspector.WordEditor
        With oDoc
            .Range(0, 0).InsertAfter xMailBody_End
            oWs.UsedRange.Copy
            .Range(0, 0).InsertAfter vbNewLine & vbNewLine & vbNewLine
            .Range(2, 2).Paste
            .Range(0, 0).InsertBefore xMailBody_Start
        End With
    End With

    oWs.Parent.Close SaveChanges:=False
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

 

[Oscarsalone]

Thank you that was very helpful. This is the variation that ended up working for me.

Private Sub Workbook_Open()
  Dim Instrument1 As String
  Dim Instrument2 As String
  
  Dim ws As Worksheet
  Dim Status As String
  Set ws = Sheets("DAQ Fault Log")
  lr = ws.Range("A" & Rows.Count).End(xlUp).Row
'  MsgBox "This code ran at Excel start!"
'    On Error Resume Next
'    If Target.Cells.Count > 1 Then Exit Sub
counter1 = 0
counter2 = 0
On Error Resume Next
For i = 2 To lr
  Status = ws.Range("P" & i).Value

    If Status = "Expiring Soon" Then
        Instrument1 = Instrument1 & ws.Range("B" & i).Value & ", "
        counter1 = counter1 + 1
    End If
    If Status = "Expired" Then
        Instrument2 = Instrument2 & ws.Range("B" & i).Value & ", "
        counter2 = counter2 + 1
    End If
Next i

If counter1 > 0 And counter1 = 1 Then Mail_Expiring_Soon_Outlook Left(Instrument1, Len(Instrument1) - 2)
If counter1 > 0 And counter1 > 1 Then Mail_Expiring_Soon_Outlook Left(Instrument1, Len(Instrument1) - 1)

If counter2 > 0 And counter2 = 1 Then Mail_Expired_Outlook Left(Instrument2, Len(Instrument2) - 2)
If counter2 > 0 And counter2 > 1 Then Mail_Expired_Outlook Left(Instrument2, Len(Instrument2) - 1)


End Sub
Sub Mail_Expiring_Soon_Outlook(Instrument1 As String)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Attention" & vbNewLine & vbNewLine & _
              "The " & Instrument1 & " calibration is due within 30 days." & vbNewLine & vbNewLine & _
              "Please arrange calibration."
    On Error Resume Next
    With xOutMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = "Calibration Due within 30 days"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

Sub Mail_Expired_Outlook(Instrument2 As String)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)
    xMailBody = "Warning!" & vbNewLine & vbNewLine & _
              "The " & Instrument2 & " calibration is expired." & vbNewLine & vbNewLine & _
              "Please arrange calibration."
    On Error Resume Next
    With xOutMail
        .to = ""
        .CC = ""
        .BCC = ""
        .Subject = "Warning! Calibration is Expired"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub

 

[GWteB]

You are welcome and thanks for letting me know.