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.
Bookmarks