Erreur automation à l'envoi de mail

anber

XLDnaute Occasionnel
Bonsoir le forum,
J'ai une erreur d'automation à l'exécution de mon code au 2e envoi de mail, je ne vois pas mon problème
Merci

Sub envoimail()

'Déclaration des variables
Dim appOutlook As Outlook.Application
Dim message As Outlook.MailItem
Dim message1 As Outlook.MailItem
Dim myRecipient As Object
Dim email As Variant
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim wb As Workbook
Dim Nom As Variant
Dim Prenom As Variant
Dim site As Variant
Dim fs As Variant
Dim Shname As Variant
Dim dest As Variant

'Crée une session Microsoft Outlook
Set appOutlook = CreateObject("outlook.application")

'Crée un nouveau message
Set message = Outlook.CreateItem(0) '(olMailItem)

Body = "Bonjour, " & vbCr & vbCr & "BLA BLA"


Set fs = CreateObject("Scripting.FileSystemObject")

Application.ScreenUpdating = False

'Declaration chemin local
TempFilePath = Environ$("temp") & "\"

'Format du fichier en excel 2003
FileExtStr = ".xls": FileFormatNum = -4143
For n = 2 To Sheets.Count
Shname = ""
dest = ""
For mag = 2 To 30
If InStr(Sheets(n).Name, Sheets(1).Cells(mag, 10)) Then
dest = Sheets(1).Cells(mag, 11)
Exit For
End If
Next

Shname = Sheets(n).Name
'Copie de la feuille du classeur
ThisWorkbook.Sheets(Shname).Copy

'Enregistrement de la feuille dans le temp
Set wb = ActiveWorkbook
wb.SaveAs TempFilePath & Shname & FileExtStr, FileFormatNum

'PDF******************
' Dim pdfjob As PDFCreator.clsPDFCreator
Dim pdfjob As Object
Dim sPDFName As String
Dim sPDFPath As String
'/// Changer le nom du fichier de sortie sur la ligne cidessous: ///
sPDFName = Shname
sPDFPath = ActiveWorkbook.path & Application.PathSeparator
'Check if worksheet is empty and exit if so
If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub
'Set pdfjob = New PDFCreator.clsPDFCreator
Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")
With pdfjob
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Can't initialize PDFCreator.", vbCritical + _
vbOKOnly, "PrtPDFCreator"
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sPDFPath
.cOption("AutosaveFilename") = sPDFName
.cOption("AutosaveFormat") = 0 ' 0 = PDF
.cClearCache
End With
'Imprime le document en PDF
ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"
'Attend que le document soit entré dans la file d'impression
Do Until pdfjob.cCountOfPrintjobs = 1
DoEvents
Loop
pdfjob.cPrinterStop = False
'Attend que l'impression du document soit terminée
Do Until pdfjob.cCountOfPrintjobs = 0
DoEvents
Loop
pdfjob.cClose
Set pdfjob = Nothing
'PDF*******************

'Fermeture de la feuille ouverte
ActiveWorkbook.Saved = True
ActiveWorkbook.Close

'Generation du mail
With message
.Subject = "test " & Shname
.Body = Body
.To = dest
'.CC = email2
.Attachments.Add TempFilePath & Shname & ".pdf"
.Display 'affichage mail avant envoi
.Send 'envoi direct
End With

'Supression du fichier dans le temp du profil
strPath = TempFilePath & schname & FileExtStr
strPath1 = TempFilePath & schname & ".pdf"

If (fs.FileExists(strPath)) Then
fs.deletefile (strPath)
End If

If (fs.FileExists(strPath1)) Then
fs.deletefile (strPath1)
End If

Next n
Application.ScreenUpdating = True

End Sub
 

Discussions similaires