VBA e-mail worksheet

[george hart]

Hi

Can anyone advise how I can change the code below to e-mail a specific worksheet. Or, the entrire spreadsheet, Or, both?? to a mail distribution list?

Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)

' Select range of e-mail addresses
Recipient = Worksheets("Sickness Reporting").Range("E" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Sickness Notification - Summary"
MailDoc.Body = "Please find attached latest sickness notification summary"
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
MsgBox "Summary e-mail sent"
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True

errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
End If
Next x
End With
End Sub

Many thanks in advance....

 

[John_w]

This should cover all 3 requirements - you just need to edit the Public Subs for your specific sheet name, email subject, body text and cells containing email addresses. The examples use email addresses in cells A2 to A4 of the sheet named "Sheet1".

Option Explicit


Public Sub Notes_Email_Workbook()

    Dim recipients As Variant
    Dim emailBodyText As String
        
    recipients = Sheets("Sheet1").Range("A2:A4").Value
    emailBodyText = "Email body text" & vbNewLine & vbNewLine & "This is the 2nd paragraph"
        
    Create_and_Send_Notes_Email "Test subject " & Now, recipients, emailBodyText, ThisWorkbook.FullName

End Sub


Public Sub Notes_Email_Worksheet()

    Dim recipients As Variant
    Dim emailBodyText As String
    Dim sheetToEmail As Worksheet
    Dim sheetToEmailFilename As String
        
    Set sheetToEmail = Sheets("Sheet1")
    
    sheetToEmailFilename = ThisWorkbook.Path & "\" & sheetToEmail.Name & " from " & ThisWorkbook.Name
    Save_Sheet sheetToEmail, sheetToEmailFilename
    
    recipients = Sheets("Sheet1").Range("A2:A4").Value
    emailBodyText = "Email body text" & vbNewLine & vbNewLine & "This is the 2nd paragraph"
        
    Create_and_Send_Notes_Email "Test subject " & Now, recipients, "Email body text", sheetToEmailFilename

    'Delete the newly created workbook containing the single sheet
    
    Kill sheetToEmailFilename
    
End Sub


Public Sub Notes_Email_Workbook_and_Worksheet()

    Dim recipients As Variant
    Dim emailBodyText As String
    Dim sheetToEmail As Worksheet
    Dim sheetToEmailFilename As String
        
    Set sheetToEmail = Sheets("Sheet1")
    
    sheetToEmailFilename = ThisWorkbook.Path & "\" & sheetToEmail.Name & " from " & ThisWorkbook.Name
    Save_Sheet sheetToEmail, sheetToEmailFilename
        
    recipients = Sheets("Sheet1").Range("A2:A4").Value
    emailBodyText = "Email body text" & vbNewLine & vbNewLine & "This is the 2nd paragraph"
        
    Create_and_Send_Notes_Email "Test subject " & Now, recipients, "Email body text", _
         ThisWorkbook.FullName & "," & sheetToEmailFilename

    'Delete the newly created workbook containing the single sheet
    
    Kill sheetToEmailFilename

End Sub


Private Sub Save_Sheet(theSheet As Worksheet, fullFilename As String)

    'Saves a copy of the specified sheet in a new workbook containing just that sheet.

    theSheet.Copy
    ActiveWorkbook.SaveAs fullFilename
    ActiveWorkbook.Close False
    
End Sub


Private Sub Create_and_Send_Notes_Email(Subject As String, recipientsArray As Variant, BodyText As String, Attachments As Variant)

    Const EMBED_ATTACHMENT As Long = 1454
    
    'Declare objects for Lotus Notes automation

    Dim NSession As Object      'NotesSession
    Dim NMailDb As Object       'NotesDatabase
    Dim NDoc As Object          'NOTESDOCUMENT - the mail document itself
    Dim NRichTextItem As Object 'The attachment rich text file object
    Dim NEmbeddedObj As Object  'The embedded object (Attachment)
    Dim AttachmentsArray As Variant
    Dim i As Integer
    
    'Start a Notes session
    
    Set NSession = CreateObject("Notes.NotesSession")       'Lotus Notes Automation Classes (OLE)
    Set NMailDb = NSession.GETDATABASE("", "")              'uses the default .nsf database
    
    If Not NMailDb.IsOpen Then
        NMailDb.OPENMAIL
    End If

    'Create a new mail document
    
    Set NDoc = NMailDb.CREATEDOCUMENT
    With NDoc
        .Form = "Memo"
        .SendTo = recipientsArray
        .Subject = Subject
        .body = BodyText
        .SAVEMESSAGEONSEND = True
    
        If TypeName(Attachments) = "String" Then
        
            'Attachments argument is a comma-separated string of filenames
            
            AttachmentsArray = Split(Attachments, ",")
            
        ElseIf TypeName(Attachments) = "Variant()" Then
        
            'Attachments argument is an array of filename strings

            AttachmentsArray = Attachments
            
        End If
        
        'For each attachment, create a rich text item with unique name and an associated embedded object
        
        For i = LBound(AttachmentsArray) To UBound(AttachmentsArray)
        
            Set NRichTextItem = .CREATERICHTEXTITEM("Attachment_" & i)
            
            If Dir(AttachmentsArray(i)) <> "" Then
                'Function EMBEDOBJECT(TYPE As Integer, CLASS As String, SOURCE As String, [OBJECTNAME])
                Set NEmbeddedObj = NRichTextItem.EMBEDOBJECT(EMBED_ATTACHMENT, "", AttachmentsArray(i))
            Else
                MsgBox "Attachment file not found: " & AttachmentsArray(i)
            End If
        Next
                
        'Send the document
        
        'SEND(ATTACHFORM As Integer, [RECIPIENTS])
        .SEND False
        
        'SAVE(FORCE As Integer, MAKERESPONSE As Integer, [MARKREAD]) As Integer
        'MARKREAD:  True - the document subject is set to black (read) in the Sent folder;  False - red (unread)
        .Save True, True, False
                
    End With
    
    'Clean up
    
    Set NMailDb = Nothing
    Set NDoc = Nothing
    Set NRichTextItem = Nothing
    Set NSession = Nothing
    Set NEmbeddedObj = Nothing
    
End Sub

PS - put the code in a standard module.

 

[george hart]

Many thanks

Ut seems to fall over where I highlighted in bold??

Set sheetToEmail = Sheets("Sickness Reporting")

sheetToEmailFilename = ThisWorkbook.Path & "\" & sheetToEmail.Name & " from " & ThisWorkbook.Name
Save_Sheet sheetToEmail, sheetToEmailFilename

recipients = Sheets("Sickness Reporting").Range("E" & x).Value
emailBodyText = "Email body text" & vbNewLine & vbNewLine & "This is the 2nd paragraph"

Create_and_Send_Notes_Email "Test subject " & Now, recipients, "Email body text", sheetToEmailFilename
'Delete the newly created workbook containing the single sheet

Kill sheetToEmailFilename

 

[John_w]

OK, it looks like you are running the Notes_Email_Worksheet macro. Have you saved the workbook containing the code before running it? You must save it first, because the code uses the ThisWorkbook.Path string and that only exists after the workbook has been saved.

What is the exact error message for the Save_Sheet sheetToEmail, sheetToEmailFilename line in bold? Try stepping through the code line by line by pressing the F8 key in the Visual Basic editor.

Also, in this line:

recipients = Sheets("Sickness Reporting").Range("E" & x).Value

what is 'x'. Where is it declared and defined? Post your entire code please.

 

[george hart]

So sorry....Here is my full code. Yet instead of e-mailing certain contents of the "Sickness Reporting" tab - which works well and I need. I also want the option of a macro to send the whole spreadsheet?

Hope this make sense...Many thanks in advance for all your help. Life saver.

Sub email()
Dim x As Integer
Dim UserName As String
Dim MailDbName As String
Dim Recipient As Variant
Dim Maildb As Object
Dim MailDoc As Object
Dim AttachME As Object
Dim Session As Object
Dim stSignature As String
With Application
.ScreenUpdating = False
.DisplayAlerts = False
' Open and locate current LOTUS NOTES User
For x = 4 To Cells(Rows.Count, "B").End(xlUp).Row
If Worksheets("Sickness Reporting").Range("B" & x) <> "" _
And Worksheets("Sickness Reporting").Range("K" & x) = "" Then
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDbName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
If Maildb.IsOpen = True Then
Else
Maildb.OPENMAIL
End If
' Create New Mail and Address Title Handlers
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
stSignature = Maildb.GetProfileDocument("CalendarProfile").GetItemValue("Signature")(0)

' Select range of e-mail addresses
Recipient = Worksheets("Sickness Reporting").Range("E" & x).Value
MailDoc.SendTo = Recipient
MailDoc.Subject = "Sickness Notification"
MailDoc.Body = "Please be advised that " & Worksheets("Sickness Reporting").Range("B" & x).Value _
& " reported in sick today at " & Worksheets("Sickness Reporting").Range("I" & x).Text _
& "." & " Details of which as follows: " & Worksheets("Sickness Reporting").Range("J" & x).Value & vbCrLf & vbCrLf & stSignature
MailDoc.SaveMessageOnSend = True
MailDoc.PostedDate = Now()
On Error GoTo errorhandler1
MailDoc.SEND 0, Recipient
MsgBox "Email sent to " & Recipient & " notifying of absence"
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
.ScreenUpdating = True
.DisplayAlerts = True

errorhandler1:
Set Maildb = Nothing
Set MailDoc = Nothing
Set Session = Nothing
Worksheets("Sickness Reporting").Range("K" & x).Value = "Y"

End If

Next x
End With
End Sub

 

[John_w]

No, you've just posted a fuller version of your original code. I want you to post your version of my code - the code that you said fell over - and tell me the exact error message displayed when you step through the code and at which line it occurs.

To prove that my code works, I suggest you create a new workbook, paste my code into a standard module in that workbook, put 3 email addresses in cells A2-A4 on Sheet1 (they can all be the same email address), save the workbook and then run the Notes_Email_Workbook macro. It should create and send a Lotus Notes email with the workbook file attached. Once we've proved that the unmodified code works, we can adapt it for your situation.

I note that your code sends separate emails for each recipient in E4 to Ex, where x is the last populated row number in column B. My code currently sends a single email to all recipients in A2-A4, but can be easily modified to send separate emails to each recipient.

 

[george hart]

Hi again

I did what you said - copied in a new file, saved it etc and it worked a treat....Thank you very much for all your help.

I think I need to do a course on VBA. Can you recommend one?

Many thanks again

 

[John_w]

Googling "Excel VBA tutorial" brings up many results.

 

[george hart]

Hi again

Thank you very much for all your help...The code you sent works a treat.

Just one more thing. Your code (below) that allows me to send the "worksheet" as an attachment. Can this be changed to send the worksheet (as an attachment) but with only with the range B3:L500?

Many thanks again...

Public Sub Notes_Email_Worksheet()
Dim recipients As Variant
Dim emailBodyText As String
Dim sheetToEmail As Worksheet
Dim sheetToEmailFilename As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

Dim x As Variant

For x = 4 To Cells(Rows.Count, "B").End(xlUp).Row

Set sheetToEmail = Sheets("Sickness Reporting")

sheetToEmailFilename = ThisWorkbook.Path & "\" & sheetToEmail.Name & " from " & ThisWorkbook.Name
Save_Sheet sheetToEmail, sheetToEmailFilename

recipients = Sheets("Sickness Reporting").Range("E" & x).Value
emailBodyText = "Please see attached sickness summary page" & vbNewLine & vbNewLine & "Distributed via the Control centre Swindon" _


Create_and_Send_Notes_Email "Sickness summary page " & Now, recipients, "Distributed via the Control Centre in Swindon" & vbNewLine & vbNewLine & "Please use the filter to view required data", sheetToEmailFilename
'Delete the newly created workbook containing the single sheet

Kill sheetToEmailFilename

Next

MsgBox "E-mail sent"

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

 

[John_w]

This saves a range of cells to a new workbook:

Private Sub Save_Range(rangeOfCells As Range, fullFilename As String)

    'Saves the specified cells in a new workbook containing just those cells.
    
    Dim newWorkbook As Workbook
        
    'Create a new workbook with one worksheet
    
    Set newWorkbook = Workbooks.Add(xlWBATWorksheet)

    'Copy specified range of cells to new workbook

    rangeOfCells.Copy newWorkbook.Sheets("Sheet1").Range("A1")
    
    'Save new workbook
    
    newWorkbook.SaveAs fullFilename
    newWorkbook.Close False
    
End Sub

A1 is the cell where the cells are copied to in the new workbook. Call it in your code like this:

    Save_Range Sheets("Sheet1").Range("B3:L500"), sheetToEmailFilename

where "Sheet1" is name of the sheet containing cells B3:L500 to be saved.