How to Send out e-mail automatically from specific range when the workbook is open

Question

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

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

Answer 1

Thought that you might be interested in a modification to the code.

The following code now adds the borders to the temporary file within the UDF code instead of altering the original source data worksheet. (It is not good programming to change the source data.)

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

    Dim Lr As Integer

    Dim rngToSend As Range

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

    With sh

        Lr = .Cells(.Rows.Count, "A").End(xlUp).Row

    End With

    Set rngToSend = sh.Range("A1:C" & Lr)

    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 'Should not be required

    With olkEm

        .To = ""

        .CC = ""

        .BCC = ""

        .Subject = "Payments Due"

        .HTMLBody = strbody & vbNewLine _

                    & RangetoHTML(rngToSend)

        .Display 'Suggest use .Display for testing purposes and can close email without saving

        '.Send 'For production code delete .Display and uncomment .Send

    End With

    Set olkEm = Nothing

    Set olkObj = Nothing

End Sub

Function RangetoHTML(rng As Range)

' By Ron de Bruin.

    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

        Call InsertBorders(.Cells(1).CurrentRegion) 'Optional to insert borders in email

        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=")

    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

Sub InsertBorders(rngForBorders As Range)

    'Inserts medium outline border and Thin internal borders

    rngForBorders.Borders(xlDiagonalDown).LineStyle = xlNone

    rngForBorders.Borders(xlDiagonalUp).LineStyle = xlNone

    With rngForBorders.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With rngForBorders.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlThin

    End With

End Sub

Answer 2

Try the following code.

You can copy all of the code into ThisWorkbook module or you can just place the Private Sub Workbook_Open()  in ThisWorkbook module and the Function and Sub InsertBorders(rngForBorders As Range) in a standard module. 

The range in the workbook needs to be converted to HTML format to copy into an email and hence the UDF (User Defined Function)

Note that the grid lines are not copied by default to the HTML format so if you want to see grid lines then the InsertBorders sub is called.

 You can comment out or delete the call to the InsertBorders sub if desired.

The UDF is credited to Ron deBruin wo is a great resource for anything to do with VBA emails.

Hope that this does what you require.

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

    Dim Lr As Integer

    Dim rngToSend As Range

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

    With sh

        Lr = .Cells(.Rows.Count, "A").End(xlUp).Row

    End With

    Set rngToSend = sh.Range("A1:C" & Lr)

    Call InsertBorders(rngToSend) 'Optional because default GridLines are not included

    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"

        .HTMLBody = strbody & vbNewLine _

                    & RangetoHTML(rngToSend)

        .Display 'Suggest use .Display for testing purposes and can close email without saving

        '.Send 'For production code delete .Display and uncomment .Send

    End With

    Set olkEm = Nothing

    Set olkObj = Nothing

End Sub

Function RangetoHTML(rng As Range)

' Credit to Ron de Bruin.

    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

Sub InsertBorders(rngForBorders As Range)

    'Inserts medium outline border and Thin internal borders

    rngForBorders.Borders(xlDiagonalDown).LineStyle = xlNone

    rngForBorders.Borders(xlDiagonalUp).LineStyle = xlNone

    With rngForBorders.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With rngForBorders.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With rngForBorders.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = xlAutomatic

        .TintAndShade = 0

        .Weight = xlThin

    End With

End Sub

Answer 3

OssieMac thank you so much for your help!! this is working flawlessly now.

Answer 4

Got it May, I've edited my post. Thanks.

Answer 5

Hi FEBIN EDWARDS,

Thank you for posting in this community.

Considering your issue is related to the macro codes, I am sorry it is more suitable to move to the category Microsoft Office Programming. So, it may have more experts in this area to further help you. Or you may continue to wait if members in this category will help you.

If you are willing to, welcome to contact me. And I will help to move your thread to the related category.

I do want to help you, however, I am sorry that I am unfamiliar with the codes.

Thank you for your understanding and efforts.

Best Regards,

May