Excel Macro to Outlook randomly doesn't work

[Faulds]

Hello! I have a code that is essentially copy/pasting excel data to the body of an Outlook email. It works correctly 95% 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 (nothing in the macro clears out data) and it is not recoverable. 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. Users use the direct path to open the document too. Very confused.
Thanks for your help!

[/COLOR]Sub SendtoOutlook()
'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
   
    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