Macro that loops through a drop down list and creates a separate attachment and email

This will create an attachment and draft email/or sent email for each name in your drop down list.

Sub PrintAll()

Dim Cell As Range
Dim Rng As Range
Dim Wks As Worksheet
Dim NotesDb As Object
Dim NotesDoc As Object
Dim NotesRTF As Object
Dim NotesSession As Object
Dim UserName As String
Dim MailDbName As String
Dim MyAttachment As String
Dim SendToRecip As Variant
Dim CopyToRecip As Variant
Dim BlindCopyToRecip As Variant
Dim MyName As Variant
Dim richStyle As Variant 'Variables for Excel.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lnLastRow As Long

  
    Set Wks = Worksheets("Summary")
    Set Rng = ThisWorkbook.Names("Employees").RefersToRange
    
      For Each Cell In Rng
        If Cell <> "" Then
            Wks.Range("$B$4").Value = Cell.Text
           
           'Activates the main summary page to get ready for copying
            Windows("Attendance-forum ver 1.xls").Activate
            'Copies the information from the summary page.
            Sheets("Summary").Range("A1:H46").Copy
            'Creates a new workbook
            Workbooks.Add
            'Pastes the data into the new workbook.
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Selection.PasteSpecial xlPasteFormats
            Range("A1").Select
            'turn off alerts
            Application.DisplayAlerts = False
            'Save the worksheet
            ActiveWorkbook.SaveAs Filename:="C:\Users\sharpp\Desktop\newworkbook.xlsx"
            ActiveWorkbook.Close
            
            'Brings focus back to the original workbook to start the process over.
            Windows("Attendance-forum ver 1.xls").Activate
            Range("A1").Select
            Application.CutCopyMode = False
            
            '**** This is where the Email code has to happen *****
            
            'Application.ScreenUpdating = False
            Set wbBook = ThisWorkbook 'Retrieve the SendTo of recipients.
            With wsSheet
                'The two lines below are not needed for the scorecard email
                'lnLastRow = Cells(Rows.Count, "C").End(xlUp).Row
                'SendToRecip = Worksheets("EmployeeList").Range("C2:C" & lnLastRow).Value
                'This is where we know who to send the email to. It refers to a cell
                ' on the Summary page with the email in it.
                SendToRecip = Worksheets("Summary").Range("$B$6").Value
            End With 'Retrieve the CClist of recipients.
            'Uncomment this if you want to put a CC list on and make srue you refer to the correct cell.
            'With wsSheet
                'lnLastRow = Cells(Rows.Count, "C").End(xlUp).Row
                'CopyToRecip = Worksheets("EmployeeList").Range("C2:C" & lnLastRow).Value
            'End With
            Const EMBED_ATTACHMENT = 1454
            Const EMBED_OBJECT = 1453
            Const EMBED_OBJECTLINK = 1452
            On Error GoTo Run_Create_Draft_Note_Error
            Set NotesSession = CreateObject("Notes.Notessession")
                  UserName = NotesSession.UserName
                  MyName = Right$((Left$(UserName, (InStr(1, UserName, "/") - 1))), (Len(Left$(UserName, (InStr(1, UserName, "/") - 1))) - 3))
            Set NotesDb = NotesSession.GetDataBase("", "")
                        
            Call NotesDb.OPENMAIL
            Set NotesDoc = NotesDb.CreateDocument
            Set richStyle = NotesSession.CreateRichTextStyle
            
            'Add all of the email information below
            Call NotesDoc.ReplaceItemValue("Subject", "--Add Subject Here--")
               NotesDoc.SendTo = SendToRecip
                'NotesDoc.CopyTo = CopyToRecip
               NotesDoc.BlindCopyTo = BlindCopyToRecip
            Set NotesRTF = NotesDoc.CreateRichTextItem("Body")
            Call NotesRTF.AddNewLine(2) 'Below embeds an attachment...
                'Be sure to put in the correct path!
                MyAttachment = "C:\Users\sharpp\Desktop\newworkbook.xlsx"
            Call NotesRTF.EmbedObject(EMBED_ATTACHMENT, "", MyAttachment)
            Call NotesRTF.AddNewLine(2)
            
            Call NotesRTF.AppendText("Add Text to appear in the Email eg. Signature")
            Call NotesRTF.AppendText("Please advise if you wish to be removed from the distribution list. ") ' Add a disclaimer section to email body.
            Call NotesRTF.AddNewLine(2)
                richStyle.FontSize = 10
                richStyle.Italic = True
                
            Call NotesRTF.AppendStyle(richStyle)
            Call NotesRTF.AppendText("Add Disclaimer Text Here")
            Call NotesRTF.AppendText(" of the information contained on this E-mail.")
            Call NotesRTF.AddNewLine(1)
                'Remove the ' on the next to lines to send each time .
                'NotesDoc.PostedDate = Now()
                'NotesDoc.Send 0, SendToRecip
                NotesDoc.RemoveItem ("DeliveredDate")
                NotesDoc.SaveMessageOnSend = True
                
            Call NotesDoc.Save(True, False) 'Call NotesDoc.send(False)
            Set NotesSession = Nothing
            
            '**** End of Email Code ****
    
        End If
        
      Next Cell
      
'This is the msg box that pops up at the end to tell you if it worked or not.
      
Run_Create_Draft_Note_Exit: MsgBox ("The E-mail has been successfully created. Please check the Lotus Notes Drafts Folder for Final Review and Submission."), vbInformation
            Exit Sub
Run_Create_Draft_Note_Error: MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
            Resume Run_Create_Draft_Note_Exit
      
End Sub