VBA to Send Email with Outlook

To help prepare macros, please attached an Excel sample file.

Is the list of Red or Orange Dies long ???
In other word, do we attach a file ( PDF one) with the list of dies or do we record the Dies reference in the Email ???

Originally Posted by PCI

Is the list of Red or Orange Dies long ???
In other word, do we attach a file ( PDF one) with the list of dies or do we record the Dies reference in the Email ???

Just the email body includes reference to the part number in column A. and Each line is the part number and what kind of warning it is. (refer to my example for email body sample)


So in the end the email will look something like:

Subject: Dies that require checking
Body: Die "XXXXX" - Please check die for completion ETA.
Die "YYYYY" - Please check die for completion ETA.
Die "ZZZZZ" - Due Today/Past Due, please follow asap.

Here what could be done

Option Explicit

Sub Treat()
Const DataWsN = "Data"
Const OrgMsg = " Please check die for completion ETA"
Const RedMsg = " is due Today/Past Due, please follow asap"
Const MsgSt = "Die "

Dim WkRg  As Range, WkRg1 As Range, Rg As Range
Dim LR As Integer

Dim EmailSubject  As String
Dim EmailStart1 As String
Dim EmailBody  As Range
Dim EmailEnd1 As String, EmailEnd2 As String
Dim Email_List As Range
Dim DestEmail As String
Dim EmailList As Range

Dim myOlApp As Outlook.Application
Dim myItem As Outlook.MailItem
    Set myOlApp = CreateObject("Outlook.Application")
    Set myItem = myOlApp.CreateItem(olMailItem)
    
Dim DataWs As Worksheet
    Set DataWs = Sheets(DataWsN)
    
'---  People Email list preparation
    Set EmailList = Range("EmailList")
    If EmailList.Rows.Count = 0 Then MsgBox (" No email to send information "): Exit Sub
    DestEmail = ""
    For Each Rg In EmailList
        If (Len(Rg) <> 0) Then DestEmail = DestEmail & "," & Rg
    Next Rg
    DestEmail = Mid(DestEmail, 2)

'---  Email info
    EmailSubject = Range("EmailSubject")
    EmailStart1 = Range("EmailStart1")
    EmailEnd1 = Range("EmailEnd1")
    EmailEnd2 = Range("EmailEnd2")
    
    With DataWs
        Set EmailBody = Range("EmailBody")
        EmailBody.ClearContents
'       Review  Dies list
        Set WkRg = .UsedRange
        If (.AutoFilterMode) Then ActiveSheet.AutoFilterMode = False '  REMOVE  AUTOFILTER  IF  EXIST
        
'       RED  Dies
        WkRg.AutoFilter Field:=8, Criteria1:=RGB(255, 0, 0), Operator:=xlFilterCellColor
        LR = .Cells(Rows.Count, 1).End(3).Row
        If (LR > 1) Then
            Set WkRg1 = Range(.Cells(2, 1), .Cells(LR, 1))
            For Each Rg In WkRg1.SpecialCells(xlCellTypeVisible)
                EmailBody = EmailBody & vbCrLf & _
                    MsgSt & Rg & RedMsg
            Next Rg
            EmailBody = Mid(EmailBody, 2)
        End If
        
'       ORANGE  Dies
        WkRg.AutoFilter Field:=8, Criteria1:=RGB(255, 192, 0), Operator:=xlFilterCellColor
        LR = .Cells(Rows.Count, 1).End(3).Row
        If (LR > 1) Then
            Set WkRg1 = Range(.Cells(2, 1), .Cells(LR, 1))
            For Each Rg In WkRg1.SpecialCells(xlCellTypeVisible)
                EmailBody = EmailBody & vbCrLf & _
                    MsgSt & Rg & OrgMsg
            Next Rg
        End If
    End With

    EmailBody = EmailStart1 & _
                EmailBody & vbCrLf & _
                EmailEnd1 & vbCrLf & _
                EmailEnd2 & vbCrLf
                
'---  Send Email
    Application.DisplayAlerts = False
    With myItem
        .To = DestEmail
        .Subject = EmailSubject
        .Body = EmailBody
        .Send
    End With
    Application.DisplayAlerts = True
    
'---  Close
    Set myItem = Nothing
    Set myOlApp = Nothing
    MsgBox ("  Email sent")
   
End Sub