Boucle envoi onglets par mail en PDF

Fermé
Jimmy59116 Messages postés 45 Date d'inscription jeudi 27 novembre 2008 Statut Membre Dernière intervention 30 janvier 2013 - Modifié par Jimmy59116 le 17/01/2012 à 16:00
Bonjour,

Je travaille sur une macro dont le but est d'envoyer les onglets de classeur par mail en PDF.

J'ai copié collé du code à droite à gauche mais ma boucle ne fonctionne pas. En fait, elle m'envoie plusieurs fois la même page. Apparemment, c'est la boucle sur la création de PDF qui me bloque. En effet, le PDF est enregistré sur le bureau puis envoyé par mail, ensuite, le programme doit revenir au début et faire la même chose pour la feuille suivante.

Une idée pour me dépatouiller ?


Sub PDF()

Dim WS_Count As Integer
Dim I As Integer

WS_Count = ActiveWorkbook.Worksheets.Count

For I = 1 To WS_Count

If I < WS_Count Then

Dim jobPDF As Object
Dim sNomPDF As String
Dim sCheminPDF As String

sNomPDF = "Essai" & WS_Count & ".pdf"
sCheminPDF = ActiveWorkbook.Path & Application.PathSeparator

If IsEmpty(ActiveSheet.UsedRange) Then Exit Sub

Set jobPDF = CreateObject("PDFCreator.clsPDFCreator")

With jobPDF
If .cStart("/NoProcessingAtStartup") = False Then
MsgBox "Initialisation de PDFCreator impossible", vbCritical + vbOKOnly, "PDFCreator"
Exit Sub
End If
.cOption("UseAutosave") = 1
.cOption("UseAutosaveDirectory") = 1
.cOption("AutosaveDirectory") = sCheminPDF
.cOption("AutosaveFilename") = sNomPDF

'0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
.cOption("AutosaveFormat") = 0
.cClearCache
End With

ActiveSheet.PrintOut copies:=1, ActivePrinter:="PDFCreator"

'Fichier dans la file d'attente
Do Until jobPDF.cCountOfPrintjobs = 1
DoEvents
Loop
jobPDF.cPrinterStop = False

'Attendre que la file d'attente soit vide
Do Until jobPDF.cCountOfPrintjobs = 0
DoEvents
Loop
jobPDF.cClose
Set jobPDF = Nothing

ESubject = "Planning"
SendTo = Range("A1")
Ebody = "Bonjour," & Chr(10) & _
" " & Chr(10) & _
"Voici le planning pour la semaine prochaine." & Chr(10) & _
" " & Chr(10) & _
"Il reste modifiable à tout moment selon les besoins du service." & Chr(10) & _
" " & Chr(10) & _
"Je t'en souhaite bonne réception ainsi qu'un bon week end." & Chr(10) & _
" " & Chr(10) & _
"Cordialement," & Chr(10) & _
" " & Chr(10) & _
"Alex" & Chr(10) & _
" " & Chr(10) & _
"Nom de la société" & Chr(10) & _
" " & Chr(10) & _
"Téléphone"


NewFileName = "C:\Users\Imotep\Desktop\Essai" & WS_Count & ".pdf"

Set App = CreateObject("Outlook.Application")
Set Itm = App.CreateItem(0)
With Itm
.Subject = ESubject
.To = SendTo
.body = Ebody
.Attachments.Add (NewFileName)
.Send
End With
Set App = Nothing
Set Itm = Nothing

End If
Next I

End Sub