Code not able to create e-mail at first go

[ThrottleWorks]

Hi,

I am using below mentioned code to create e-mail.
This code works perfect in other macros of mine.

However, when I try to run this macro in a particular macro, am getting an error as
'Automation error' system failed, I just press F8 when I face this bug and macro runs smoothly there after.

But it gets stuck at first instance. please note, Outlook is open while running this macro.

Can anyone please help me in this.

Sub RangeToHML_Ron()

    Dim EmailRng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set EmailRng = Nothing
    Set EmailRng = Selection.SpecialCells(xlCellTypeVisible)
  
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
  
    Dim MyPath As String
    MyPath = ActiveWorkbook.FullName
  
    With OutMail
        .To = EmailSht.Range("C9").Value
        .CC = EmailSht.Range("D9").Value
        '.BCC = EmailMapSht.Range("B1").Value
        .Subject = EmailSht.Range("E9").Value
        '.Attachments.Add MyPath
        .HTMLBody = RangetoHTML(EmailRng)
        .Display
    End With
  
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    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"

    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

    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

    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
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Monty]

Hello ThrottleWorks

Can i have uploaded file please...Happy to help you.