Untitled

Public Sub SubCreateEmailBasedonList()
    Dim lngX As Long
    Dim strFilePath As String
    Dim strCC As String
    lngX = 2
    Do While shtMain.Cells(lngX, 1) <> vbNullString
        strFilePath = ThisWorkbook.Path & "\Output\" & shtMain.Cells(lngX, 1) & " Leader Settlement Option Letter.pdf"
        strCC = shtMain.Cells(lngX, 13) & ";" & shtMain.Cells(lngX, 14) ' Combine CC recipients from columns M and N
        CreateEmailOutContract shtMain.Cells(lngX, 12), strCC, "", shtMain.Cells(lngX, 1), strFilePath ' No BCC in this call
        lngX = lngX + 1
    Loop
End Sub

Private Sub CreateEmailOutContract(ByVal strTO As String, ByVal strCC As String, ByVal strBCC As String, ByVal strName As String, ByVal sFile As String)
    Dim objOutlook As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim Signature As String
    Dim sBody As String
    
    Set objOutlook = New Outlook.Application
    Set objMail = objOutlook.CreateItem(0)
    objMail.Display
    Signature = objMail.HTMLBody
    With objMail
        .Attachments.Add sFile
        sBody = "<HTML><BODY><P>Dear <B>" & strName & ",</B></P>" & _
        "<P>As part of the process related to your DOU clawback, we are sending you a letter outlining the details.  Please take the time to review the letter thoroughly and provide and feedback within the specified timeframe.<br><br>Thank you for your cooperation.</P>" & _
        "</BODY></HTML>"
        .subject = "Leader Settlement Option " & strName
        .To = strTO
        .CC = strCC
        .BCC = strBCC
        '.SentOnBehalfOfName = "distributionsupport.ph@fwd.com"
        .HTMLBody = sBody & vbNewLine & Signature
        .Save
    End With
    Set objOutlook = Nothing
    Set objMail = Nothing
    ThisWorkbook.Activate
End Sub
Editor is loading...