XL 2013 Erreur d'exécution 1004

mozaku

XLDnaute Nouveau
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 :

1572867040760.png

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 x:publishsource=", "align=left x:publishsource=")

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
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas