XL 2013 Erreur d'exécution 1004

[mozaku]

Bonjour,
Je rencontre un problème régulier lorsque j'utilise le script VBA qui me permet d'envoyer un mail avec une pièce jointe.
le problème est rencontré à la partie suivante (je précise que des fois ça marche et des fois ça marche pas)
Merci d'avance pour votre aide habituelle.

ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True

j'ai le message d'erreur suivant :

Ci-dessous le code complet :
Option Explicit
Public Sub prcSendMail()
Dim objOutlook As Object, objMail As Object

Set objOutlook = CreateObject(Class:="Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "" 'ici je mis le mail du destinataire
.cc = ""
.Subject = Sheets("Synthèse").Range("H1").Text
.HTMLBody = fncRangeToHtml("Synthèse", "A3:I45")
.Attachments.Add "" 'ici je récupère le fichier d'un serveur local du type \\IP\Dossier\Fichier.xlsx
.Send
End With
Set objMail = Nothing
Set objOutlook = Nothing
ThisWorkbook.Save
Application.Quit
End Sub

Private Function fncRangeToHtml( _
strWorksheetName As String, _
strRangeAddress As String) As String

Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
Dim strFilename As String, strTempText As String
Dim blnRangeContainsShapes As Boolean

strFilename = Environ$("temp") & "\" & _
Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"

ThisWorkbook.PublishObjects.Add( _
SourceType:=xlSourceRange, _
filename:=strFilename, _
Sheet:=strWorksheetName, _
Source:=strRangeAddress, _
HtmlType:=xlHtmlStatic).Publish True

Set objFilesytem = CreateObject("Scripting.FileSystemObject")
Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
strTempText = objTextstream.ReadAll
objTextstream.Close

For Each objShape In Worksheets(strWorksheetName).Shapes
If Not Intersect(objShape.TopLeftCell, Worksheets( _
strWorksheetName).Range(strRangeAddress)) Is Nothing Then

blnRangeContainsShapes = True
Exit For

End If
Next

If blnRangeContainsShapes Then _
strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))

fncRangeToHtml = strTempText
fncRangeToHtml = Replace(fncRangeToHtml, "align=center xublishsource=", "align=left xublishsource=")

Set objTextstream = Nothing
Set objFilesytem = Nothing

Kill strFilename

End Function
Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String

Const HTM_START = "<link rel=File-List href="
Const HTM_END = "/filelist.xml"

Dim strTemp As String
Dim lngPathLeft As Long

lngPathLeft = InStr(1, strTempText, HTM_START)

strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft)
strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
strTemp = strTemp & "/"

strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp)

fncConvertPictureToMail = strTempText

End Function