Can't Find Bug in Excel to Outlook VBA Code

[Faulds]

Hello! I have a code that is essentially copy/pasting excel data to the body of an Outlook email. It works correctly 90% of the time, but I have had some users experience issues with ONLY the headers copying over to Outlook (no input data) and then the Excel spreadsheet data is cleared out. What should happen is they open the workbook in read only, type their data, press the macro button and it should copy/paste headers & data into a new Outlook email. It should not clear their data from the Excel sheet.
Can you help me figure out why sometimes it works correctly and sometimes it doesn't?

I was able to replicate the issue after saving a copy of the workbook to my desktop and after creating a shortcut to the workbook link on my desktop, but even then it only replicates the issue some of the time and other times it works. Very confused.
Thanks for your help!

Sub RoundedRectangle2_Click()
'Format and Sort Data
Dim sh As Worksheet
    Set sh = ActiveSheet


    sh.Unprotect


        ActiveWorkbook.Worksheets("Daily Override").AutoFilter.Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Daily Override").AutoFilter.Sort.SortFields.Add _
        Key:=Range("A3:A398"), SortOn:=xlSortOnValues, Order:=xlAscending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Daily Override").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveWorkbook.Worksheets("Daily Override").AutoFilter.Sort.SortFields. _
        Clear
    ActiveWorkbook.Worksheets("Daily Override").AutoFilter.Sort.SortFields.Add _
        Key:=Range("B3:B398"), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Daily Override").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$3:$P$398").AutoFilter Field:=2, Criteria1:="<>"




'Copy the function RangetoHTML in the module.
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object


    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Daily Override").Range("A1:P388").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If


    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With


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


    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "IO Override"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0


    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With


    Set OutMail = Nothing
    Set OutApp = Nothing


sh.Protect


End Sub
Function RangetoHTML(rng As Range)
' Working in Office 2000-2016
    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 paste 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

 

[mole999]

are you all using the same input html/rtf etc, I can see that could make an issue

 

[Faulds]

are you all using the same input html/rtf etc, I can see that could make an issue

Thank you for reviewing my question!
Can you elaborate? I'm not sure how I would verify that?

 

[Faulds]

To elaborate on my question/situation, I have a read-only excel document, so everyone is opening the same document from a saved/linked location. It is opened fresh every time. If not opened fresh, it is either saved as a shortcut or a copied file. The macro automatically opens the new Outlook mail object and inserts the information, so the user does not have the opportunity to change the Outlook email format. Are you suggesting that it could be a setting in each user's Outlook background? If so, I'm confused why users would sometimes get the error and sometimes not.
Thanks again!

 

[mole999]

if you create an email you have three choices in how to compose, plain text / html and RTF is each user using the same settings you are using. MS did an update the other day and broke the RTF file insert, works if you set up for HTML (this may or may not be the cause) .

The other thing I had to do years ago was to make sure outlook was started, as not every user had it on

 

[Faulds]

if you create an email you have three choices in how to compose, plain text / html and RTF is each user using the same settings you are using. MS did an update the other day and broke the RTF file insert, works if you set up for HTML (this may or may not be the cause) .

The other thing I had to do years ago was to make sure outlook was started, as not every user had it on

Good thought to check that - and interesting that MS did an update that broke RTF file insert! That's a good thing for me to keep in mind are the updates.
The user does not open up their own Outlook email, the VBA Macro automatically opens one up for them and pastes the HTML data into the body.
My setting is set to always compose in HTML, so I don't think this is the issue since sometimes the macro works and sometimes it doesn't. I can't identify anything that I (or other users) are doing differently in the situations when it works versus the situations when it doesn't.
Thanks again for your insight - it's helping me continue to think through other options.