Automated emails based on Expiry date of different machines

Oscarsalone

New Member
Joined
Oct 26, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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
 

Some videos you may like

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
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.

VBA Code:
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
 
Solution

Oscarsalone

New Member
Joined
Oct 26, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Thank you that was very helpful. This is the variation that ended up working for me.

VBA Code:
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

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
You are welcome and thanks for letting me know.
 

Watch MrExcel Video

Forum statistics

Threads
1,127,601
Messages
5,625,749
Members
416,133
Latest member
ToseSenpai

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top