Macro pdf par mail bloquée
Bonjour, je viens d'intégrer une nouvelle société.
Je travaille depuis quelques temps sur plusieurs macros.
J'ai toute les semaines un grand tableau à traiter au sujet des location de voitures.
C'est un tableau qui va de la colonne A à L, et qui relate plusieurs informations
Il y a en colonne J, le nom du vendeur
La première macro permet de créer un onglet par vendeur.
On retrouve toutes les ventes relatives au vendeur en question dans chacun des onglets.
De plus, l'onglet porte le nom du vendeur.
La deuxième macro permet d'envoyer en pdf, par mail, l'onglet à son destinataire, en sachant que l'adresse mail du vendeur en question est en K8 pour chacun des vendeur.
La macro ne fonctionne plus.
De plus, j'aimerais que la macro s'applique à tous les onglets sauf le premier.
Je vous met mon travail en PJ.
Merci d'avance
Bonsoir Nassim,
Dans la procédure "Sub Mail_PDF_Pour_Chaque_Onglets_Destinaire_en_K8_Semaine_en_Cours", si tu mets à "True" la valeur du .send dans le code :
'If publishing is OK create the mail
If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:=sh.Range("K8").Value, _
StrCC:=sh.Range("L8").Value, _
StrBCC:="", _
StrSubject:="Location de véhicule", _
Signature:=True, _
Send:=True, _
StrBody:="<H3><B>Bonjour</B></H3><br>" & _
"<body>Veuillez trouver ci-joint les voitures louées cette semaine." & _
"<br><br>" & "Cordialement.</body>"d'après moi ça doit partir...
NB: une session outlook doit être active sur ton poste de travail pour que ça marche.
Bonjour Gérard,
Je vous remercie pour votre réponse mais le problème n'est pas là
Les mails partent dès que le pdf temporaire est créé.
Le pb est que la macro ne transforme que les 2 premiers onglets en pdf temporaires.
Il faudrait pouvoir transformer tout les onglets en pdf temporaires, sauf le premier.
Je vous remercie pour toutes les aides et tout les conseils
Bonjour,
C'est bien compliqué ces macros !
Essaie ceci :
Sub Mail_PDF_Pour_Chaque_Onglets_Destinaire_en_K8_Semaine_en_Cours()
Dim messagerie As Object
Dim email As Object
Dim nompdf As String
Dim sh As Worksheet
On Error GoTo erreur
For Each sh In ThisWorkbook.Worksheets
If sh.Range("K8").Value Like "?*@?*.?*" Then
If sh.Name <> ActiveSheet.Name Then
sh.PageSetup.PrintArea = "$A:$I"
nompdf = Environ("Temp") & "\" & "Véhicules loués pour la semaine en cours " & sh.Name
sh.ExportAsFixedFormat Type:=xlTypePDF, FileName:=nompdf & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set messagerie = CreateObject("Outlook.Application")
Set email = messagerie.CreateItem(0)
With email
.to = sh.Range("K8").Value
.CC = sh.Range("L8").Value
.Subject = "Location de véhicule"
.HTMLbody = .HTMLbody & "<H3><B>Bonjour</B></H3><br>" & _
"<body>Veuillez trouver ci-joint les voitures louées cette semaine." & _
"<br><br>" & "Cordialement.</body>"
.ReadReceiptRequested = True
.Attachments.Add nompdf & ".pdf"
.display
End With
Set email = Nothing
Set messagerie = Nothing
Kill nompdf & ".pdf"
End If
End If
Next
Exit Sub
erreur:
MsgBox "Erreur : " & Err.Number & vbLf & Err.Description
End Subsi ok, remplace .Display par .Send
Bonjour Steelson
J'ai essayé votre macro mais le problème persiste, seulement le premier mail pour "Gérard" se prépare et la macro s'arrête avec le message suivant :
"Erreur : 1004
Document non enregistré. Le document est peut-être ouvert ou une erreur s'est produite lors de l'enregistrement."
Auriez-vous une solution?
Je vous remercie pour vos conseils
efface la ligne
Kill nompdf & ".pdf"et dis moi si ok
J'ai effacé la ligne en question mais le problème est toujours le même.
Il n'y a que le mail pour Gérard qui se prépare et toujours le m^me message d'erreur
Cordialement
Ben, je n'ai pas d'erreurs et voici les 3 fichiers pdf créés par la macro !
Donc je suis sec sur ton problème ...
Ré-essaye quand même sans la ligne kill et essaie de trouver dans temp au moins le premier fichier ...
pour moi c'est ici
C:\Users\Michel\AppData\Local\Tempok j'ai vu
essaie avec send directement (sur ton adresse par exemple)
comme je n'ai pas outlook ici, je n'ai pas pu tester cette partie, mais le problème vient d'ici
Set email = Nothing
Set messagerie = Nothingcar en fait je tente d'annuler le message affiché qui n'a pas été envoyé
sinon je vais corriger demain sachant que je ne pourrai pas tester outlook
Essaie cette version (j'ai exploré mes archives)
Sub Mail_PDF_Pour_Chaque_Onglets_Destinaire_en_K8_Semaine_en_Cours()
Dim messagerie As Object
Dim email As Object
Dim nompdf As String
Dim sh As Worksheet
On Error GoTo erreur
Set messagerie = CreateObject("Outlook.Application")
For Each sh In ThisWorkbook.Worksheets
If sh.Range("K8").Value Like "?*@?*.?*" Then
If sh.Name <> ActiveSheet.Name Then
sh.PageSetup.PrintArea = "$A:$I"
nompdf = Environ("Temp") & "\" & "Véhicules loués pour la semaine en cours " & sh.Name
sh.ExportAsFixedFormat Type:=xlTypePDF, FileName:=nompdf & ".pdf", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set email = messagerie.CreateItem(0)
With email
.to = sh.Range("K8").Value
.CC = sh.Range("L8").Value
.Subject = "Location de véhicule"
.HTMLbody = .HTMLbody & "<H3><B>Bonjour</B></H3><br>" & _
"<body>Veuillez trouver ci-joint les voitures louées cette semaine." & _
"<br><br>" & "Cordialement.</body>"
.ReadReceiptRequested = True
.Attachments.Add nompdf & ".pdf"
.display
End With
Set email = Nothing
Kill nompdf & ".pdf"
End If
End If
Next
Set messagerie = Nothing
Exit Sub
erreur:
MsgBox "Erreur : " & Err.Number & vbLf & Err.Description
End SubUn grand merci pour ton aide, ça marche!
Saurais tu comment faire pour y ajouter ma signature outlook en bas des mails.
Encore merci
Hé bien, écris alors :
.HTMLbody = "<H3><B>Bonjour</B></H3><br>" & _
"Veuillez trouver ci-joint les voitures louées cette semaine." & _
"<br><br>" & "Cordialement." & .HTMLbodyen remplacement des 3 lignes du .HTMLBody
J'essaye ça en rentrant ce soir
Je suis en train d'essayer d'insérer de copie le logo de a cellule A1 de la page extraction sur tous les onglets crées?
Je te tiens au courant pour la signature.
Merci Steelson
J'essaye ça en rentrant ce soir
Je suis en train d'essayer d'insérer de copie le logo de a cellule A1 de la page extraction sur tous les onglets crées?
Je te tiens au courant pour la signature.
Merci Steelson
Steelson, j'ai essayé la modification pour mettre la signature et c'est bon.
je te mets ci dessous le code que j'ai ajouté à la partie extraction pour ajouter le logo de la société en A1 de tous les onglets.
Dim Ls As Worksheet
Application.ScreenUpdating = False
For Each Ls In Worksheets
Dim ficimg As Variant, Plage As Range, Sht As Worksheet
Ls.Select
ficimg = "F:\...............png" ' placer l'mage dans Votre Dossier
If ficimg = "Faux" Then
MsgBox "L'image nommée LOGO avec extension .png n'existe pas"
Exit Sub 'cliquer sur annuler
End If
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
Set Plage = [A1:B4]
With Selection.ShapeRange
.LockAspectRatio = False ' proportions d'origine lorsque vous la redimensionnez
.Top = Plage.Top ' haut de la cellule
.Left = Plage.Left ' gauche de la cellule
.Width = Plage.Width ' largeur de la cellule
.Height = Plage.Height ' hauteur de la cellule
End With
With Selection
.PrintObject = True ' l'objet est imprimé en même temps que le document
.Placement = xlMoveAndSize ' manière dont l'objet est lié aux cellules
End With
Application.ScreenUpdating = True
Next LsJ'ai systématiquement un débogage, que je résous en faisant effacer et entrer et play, je ne comprends pas
comment faire pour ne plus avoir de débogage?
Bien cordialement
sur quelle ligne le débogage ?
au passage, je suis étonné par ceci
If ficimg = "Faux" Thenje ne comprends pas que cela puisse marcher ... à moins de donner Faux à la valeur de ficing
Ok. Auriez vous une solution pour mettre un logo situé dans un dossier, en cellule A1 de tous les onglets créés par la macro extraction.
Je voudrais aussi que le code permettant de modifier la largeur des colonnes ne s'applique qu'aux onglets créés et non pas à la feuille extraction.
Je cherche mais je ne trouve pas.
Comment faire?
Merci par avance.
Bonjour,
déjà, quelle est la réponse au post précédent ? où se situe, sur quelle ligne se situe l'erreur ?
Bonsoir Steelson,
Pour l'insertion du logo sur tous les onglets, le débogage se met sur la ligne qui commence par :
ActiveSheet.Pictures.Insert(ficimg).Select ' insertion
Dim ficimg As Variant, Plage As Range, Sht As Worksheet
Ls.Select
ficimg = "F:\Execution V2\Base de données\Logo\xxxx.png" ' placer l'mage dans VotreDossier
If ficimg = "Faux" Then
MsgBox "L'image nommée LOGO avec extension .png n'existe pas"
Exit Sub 'cliquer sur annuler
End If
Application.ScreenUpdating = FalsePour la largeur, le code que j'ai mis est le suivant :
For Each Ws In ThisWorkbook.Worksheets
With Ws
.Columns("A:A").ColumnWidth = 2.55
.Columns("B:B").ColumnWidth = 20
.Columns("C:C").ColumnWidth = 13
.Columns("D:D").ColumnWidth = 5.64
.Columns("E:E").ColumnWidth = 16
.Columns("F:F").ColumnWidth = 6.73
.Columns("G:G").ColumnWidth = 5.09
.Columns("H:H").ColumnWidth = 6.45
.Columns("I:I").ColumnWidth = 8
.Columns("J:J").ColumnWidth = 15
.Columns("K:K").ColumnWidth = 19
.Columns("L:L").ColumnWidth = 19
End With
Next WsLe problème est que je n'arrive pas à faire en sorte que la largeur des colonnes définies ci dessus ne s'appliquent pas à la première feuille nommée "extraction".
Je met le fichier complet en PJ pour pouvoir modifier directement dessus.
Merci
Pour la largeur, le code que j'ai mis est le suivant :
Le problème est que je n'arrive pas à faire en sorte que la largeur des colonnes définies ci dessus ne s'appliquent pas à la première feuille nommée "extraction".
dans ce cas ajoute cette instruction
For Each ws In ThisWorkbook.Worksheets
If ws.Name <> "extraction" Then
With ws
.Columns("A:A").ColumnWidth = 2.55
.Columns("B:B").ColumnWidth = 20
.Columns("C:C").ColumnWidth = 13
.Columns("D:D").ColumnWidth = 5.64
.Columns("E:E").ColumnWidth = 16
.Columns("F:F").ColumnWidth = 6.73
.Columns("G:G").ColumnWidth = 5.09
.Columns("H:H").ColumnWidth = 6.45
.Columns("I:I").ColumnWidth = 8
.Columns("J:J").ColumnWidth = 15
.Columns("K:K").ColumnWidth = 19
.Columns("L:L").ColumnWidth = 19
End With
End If
Next wsje vais essayer de comprendre pour le reste