Why is my email code sending a blank email?

Hello everyone,
I thought I had this all figured out, (thanks to Leith) but alas, I don't. I have code that creates a sheet with updated information only, which is by date and currentuser. Then it is supposed to email that sheet as and HTML in the body of the email. This is all done when a user clicks a button on the userform. Everything works as expected except the email part of the code. Instead of emailing it as HTML in the body of the email, it attaches it to the email but the email and attachment are blank. Can someone take a look at the code below and see where I have gone wrong, please?

Function RangetoHTML(Rng As Range)

    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim Cell        As Range
    Dim CurrentUser As String
    Dim DateToPick  As Date
    Dim EndRow      As Long
    Dim FirstFind   As String
    Dim NewSheet    As Worksheet
   
    Dim Row         As Long
    Dim rngFind     As Range
    Dim rngPicked   As Range
    Dim SrcRng      As Range

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to paste the data in
    Rng.Copy
        CurrentUser = Environ("username")
         DateToPick = Date
    'Create New Sheet or add to it.
        On Error Resume Next
            Set NewSheet = Worksheets(Format(DateToPick, "dd-mm-yyyy"))
            If Err = 9 Then
                Set NewSheet = Sheets.Add(After:=ActiveSheet)
                NewSheet.Name = "End of Shift Report"
            End If
        On Error GoTo 0
        
        With Worksheets("Before")
            EndRow = .Cells(Rows.Count, "A").End(xlUp).Row
            Set Rng = .Range("A1:B" & EndRow)
            Set SrcRng = .Range("A1:F" & EndRow)
            SrcRng.Rows(1).Copy NewSheet.Range("A1")
        End With

            Set rngFind = Rng.Find(CurrentUser, , xlValues, xlWhole, xlByRows, xlNext, False, False, False)
    
            If Not rngFind Is Nothing Then
            
                FirstFind = rngFind.Address
                Set rngPicked = rngFind
                
                Do
                    Set rngPicked = Union(rngPicked, rngFind)
                    Set rngFind = Rng.FindNext(rngFind)
                    If rngFind Is Nothing Then Exit Do
                    If rngFind.Address = FirstFind Then Exit Do
                Loop
                
                
                Row = NewSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
                
                For Each Rng In rngPicked.Areas
                    For Each Cell In Rng.Rows
                        If Cell.Offset(0, -1) = DateToPick Then
                            SrcRng.Rows(Cell.Row).Copy NewSheet.Cells(Row, "A")
                            Row = Row + 1
                        End If
                    Next Cell
                Next Rng
                
                NewSheet.Columns("A:A").NumberFormat = "mm/dd/yy"
                
            End If

    'Read all data from the htm file into RangetoHTML
                Set fso = CreateObject("Scripting.FileSystemObject")
                Set ts = fso.GetFileNewSheet.Name("End of Shift Report").OpenAsTextStream(1, -2)
                RangetoHTML = ts.readall
                              ts.Close
                RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
                Application.Delete.Sheets ("End of Shift Report")
    '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

Sorry about the lengthy code.

I'm not sure you've posted the correct code. This function converts a range of cells to HTML. Perhaps there is another macro calling this function and also creating the email that isn't working?

Jerry,
Thank you for the response. I wasn't sure if I should include the other code or not, that is why I left it out. You are correct though, there is another macro calling this function, here it is......

Private Sub CloseButton_Click()

    Dim Rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    If MsgBox("Are you sure you want to save, close and email the EOS report?", vbYesNo + vbQuestion) = vbYes Then
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
   

    Set Rng = Nothing
    Set Rng = ActiveSheet.UsedRange
    

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

    On Error Resume Next
    With OutMail
        .To = "me@MyEmail.com"
        .CC = ""
        .BCC = ""
        .Subject = "Auto email HTML test"
        .HTMLBody = RangetoHTML(Rng)
        .Send   'or use .Display
        
    End With
    On Error GoTo 0
       'If MsgBox("Send Email?", vbYesNo + vbQuestion) = vbYes Then <---- Testing purpose only
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    Unload UserForm1
    Else
   End If
   'End If
End Sub

Ok, I've used that code before, I'm sure we all have. I don't see anything obvious wrong with that email code. Comment out this line:

On Error Resume Next

....hopefully a meaningful error will occur and your can DEBUG to see which line of code is failing you.

Ok, it errors out at this line...

Set NewSheet = Worksheets(Format(DateToPick, "dd-mm-yyyy"))

As well as this line....

Set ts = fso.GetFileNewSheet("End of Shift Report").OpenAsTextStream(1, -2)

When I remove the On Error Resume Next lines individually

You're failing on the object name, the name of the sheet doesn't match what you're feeding in in some way. What was the error? Subscript out of range? That means a named object is is incorrect.

My bad, I can't believe I didn't include the error I was getting. I will update with the error this morning.

Jerry,
Ok, I figured out the first part (I think). I removed the "On error resume next" as you suggested. Then I noticed there was an "If error = 9" so I removed that as well as it was just "skipping" that part anyway and creating and naming the sheet like I wanted. Now I get a "Run-time error 438: Object doesn't support this property or method" at this line..

Set ts = fso.GetFileNewSheet("End of Shift Report").OpenAsTextStream(1, -2)

I will play around with it some more to see if I can get it figured out. If I don't post anything, I haven't figured it out and could still use your help.

Edit* Ok, I figured something else out. The first bit of code I posted is creating a temp file and the line it errors out on is "getting" that temp file (in the original code before I started changing things around). The problem is that the temp file has nothing in it, the information I am trying to grab is actually put into a newly created worksheet (End of shift Report) that is in the same workbook that the code and is in.
My question is, what does the

Set ts = fso.

need to be in order for me to pull the information from the newly created sheet in the active workbook?

Solved per this thread
http://www.excelforum.com/excel-prog...-with-vba.html
Thank you Gregor Y