VBA for Emailing multiple worksheets to individual recipient lists

[Resko]

Hello,

First time poster here.

I have a workbook with a Macro (created by someone that's no longer with the business) that emails each worksheet (approx 30) to a recipient list in each worksheet.

It basically copies and pastes each sheet into a new workbook, saves the file into a temp folder, attaches to a new email and sends. Then Deletes the file from the temp folder

This has been working swimmingly, until I found out my work is changing from Lotus notes to outlook 2013. I need it to basically do the same thing but now for outlook.

I've pasted the code below, hopefully someone can help?

Sub Send_Sheets_Notes_Email()
 
  'Notes parameter for attaching the Excel files.
  Const EMBED_ATTACHMENT As Long = 1454
 
 'A folder to temporarily store the created Excel files in.
  Const stPath As String = "H:\Temp"


 
  'The subject for the outgoing e-mails.
  Dim stSubject As String
  stSubject = InputBox("Please enter subject line")
 
  'The message in the bodies of the outgoing e-mails.
 
 Dim vaMsg As Variant
  
 'MainMessage.Show
  
  'vaMsg = MainMessage.TextBox1.Value
  vaMsg = InputBox("Please enter body")
 
  'Variable that holds the list of recipients for each worksheet.
  Dim vaRecipients As Variant
 
  'Variable which holds each worksheet's name.
  Dim stFileName As String
 
  'Variables for Notes.
  Dim noSession As Object
  Dim noDatabase As Object
  Dim noDocument As Object
  Dim noEmbedObject As Object
  Dim noAttachment As Object
  Dim stAttachment As String
  Dim lnLastRow As Long


 
  'Variables for Excel.
  Dim wbBook As Workbook
  Dim wsSheet As Worksheet


 
  On Error GoTo Error_Handling
 
  Application.ScreenUpdating = False
 
  Set wbBook = ThisWorkbook
 
  'Loop through the collection of worksheets in the workbook.
  For Each wsSheet In wbBook.Worksheets
    'With wsSheet
      'Copy the worksheet to a new workbook.
      '.Copy
      
      If wsSheet.Range("O1").Value Like "?*@?*.?*" Then
      wsSheet.Copy
    
    Cells.Copy
     Cells.PasteSpecial xlPasteValues
  Cells(1).Select


  
      'Retrieve the worksheet's name.
      stFileName = wsSheet.Name
    'End With


 
    'Create the full path and name of the workbook.
    stAttachment = stPath & "\" & stFileName & ".xls"
 
    'Save and close the temporarily workbook.
    With ActiveWorkbook
      .SaveAs stAttachment
      .Close
    End With
 
    'Retrieve the list of recipients.
    With wsSheet
      lnLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
      vaRecipients = .Range("O1:O20" & lnLastRow).Value
    End With
 
    'Instantiate the Lotus Notes COM's Objects.
    Set noSession = CreateObject("Notes.NotesSession")
    Set noDatabase = noSession.GETDATABASE("", "")
 
    'If Lotus Notes is not open then open the mail-part of it.
    If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
 
    'Create the e-mail and add the attachment.
    Set noDocument = noDatabase.CreateDocument
    Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
    Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
 
    'Add values to the created e-mail main properties.
    With noDocument
      .Form = "Memo"
      .SendTo = vaRecipients
      .Subject = stSubject
      .Body = vaMsg
      .SaveMessageOnSend = True
      .PostedDate = Now()
      .Send 0, vaRecipients
    End With
    'Delete the temporarily workbook.
     Kill stAttachment


  End If
  Next wsSheet
 
 
 
  MsgBox ("The e-mails have been created and distributed"), vbInformation
 
ExitSub:
  'Release objects from memory.
  Set noEmbedObject = Nothing
  Set noAttachment = Nothing
  Set noDocument = Nothing
  Set noDatabase = Nothing
  Set noSession = Nothing
 
  Exit Sub
 
Error_Handling:
  MsgBox "Error number: " & Err.Number & vbNewLine & _
      "Description: " & Err.Description, vbOKOnly
  Resume ExitSub
End Sub