How Send automatic Email from selected Excel range when the workbook is open.

[Febinedwards123]

Can someone please help me with what is wrong with the below code ? I don't get any error but the problem is the range / table from intended worksheet is not getting copied to the email body.

>>> use code - tags <<<

Private Sub Workbook_Open()

'send automated email when workbook is open

    Dim olkObj As Object

    Dim olkEm As Object

    Dim strbody As String

    Dim sh As Worksheet
    Set sh= ThisWorkbook.sheets("Payments Due")

Dim Lr as integer
Lr = sh.range("A" & Application.Rows.count).End(x1Up).Row

Sh.Range("A1:C" & Lr).select

    Set olkObj = CreateObject("Outlook.Application")

    Set olkEm = olkObj.CreateItem(0)

    strbody = "Hi there" & vbNewLine & vbNewLine & _

              ThisWorkbook.Name & vbNewLine & _

              "was opened by" & vbNewLine & _

              Environ("username")

    On Error Resume Next

    With olkEm

        .To = ""

        .CC = ""

        .BCC = ""

        .Subject = "Payments Due"

        .Body = strbody

        .Send

    End With

    On Error GoTo 0

    Set olkEm = Nothing

    Set olkObj = Nothing

End Sub

 

[Febinedwards123]

Thank you for looking into this. Sorry for any confusion. I have attached a sample file with the same code.

 

[Keetoowah]

Hi Febinedwards123,

- there is no instruction in your code that pastes the selected range

- Workbook Events must be stored in ThisWorkbook module, not in a standard module

- you wrote in the code

Set sh= ThisWorkbook.sheets("Payments Due")

but the sheet name is Payment Due, without the final s

- remember to enter a valid email in the .to field.

Try this code:

Private Sub Workbook_Open()
Dim olkObj As Object
Dim olkEm As Object
Dim sh As Worksheet

Set sh = ThisWorkbook.Sheets("Payment Due")

Dim Lr As Long

Lr = sh.Range("A" & Rows.Count).End(xlUp).Row

sh.Range("A1:C" & Lr).Select

Set olkObj = CreateObject("Outlook.Application")

Set olkEm = olkObj.CreateItem(0)

On Error Resume Next

With olkEm
    
    Dim oObjetWord As Object
    Set oObjetWord = .GetInspector.WordEditor
    
    .To = "" ' MAIL
    .CC = ""
    .BCC = ""
    .Subject = "Payments Due"
    .Body = sh.Range("A1:C" & Lr).Select
        Selection.Copy
        oObjetWord.Range(0).Paste
    .Send
    
End With

On Error GoTo 0

Set olkEm = Nothing
Set olkObj = Nothing

End Sub

 

[Logit]

This is one method :

'This macro copies the used range (as specified) of the indicated sheet name
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Pivot1")  '<<-- edit sheet name as required
    ws1.Range("A1:N79").Copy
    Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String

Dim xPath As String
Dim xWs  As String

xPath = Application.ActiveWorkbook.Path

Set rng = Nothing
' Only send the used cells in the sheet
Set rng = Sheets("Pivot1").Range("A1:N79")  '<<----- edit range as required

If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If

'Turn off screen updating to prevent flickering / flashing
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"

    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
        
    ' In place of the following statement, you can use ".Send" to
    ' Send the e-mail message.
    .Display
End With

On Error GoTo 0

'Turn on screen updating
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

'Delete the temporary .xlsx file created for attachment
Kill "C:\Users\gagli\Desktop\Email Range n Sheet\*.xlsx"

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

''<<<>>> There is no need to edit anything in this Function.

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    
    Set TempWB = Workbooks.Add(1)
    
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    
    'Delete the htm file we used in this function
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
    
End Function