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