Plusieurs feuilles en pdf par email
Bonjour
j'ai une macro qui fonctionne plutôt bien et permet d'enregistrer plusieurs feuille de mon classeur en pdf avec un nom de fichier voulu.
J'aimerai savoir si il est possible de joindre se fichier pdf, à un email avant de finir l'enregistrement ou après, un peu a l'identique de :
Application.Dialogs(xlDialogSendMail).Show
Voilà mon code :
Sub PDF()
Sheets(Array("Intro", "CAgen", "CAgen_Mois", "CA_invoice", "Catalogue")).Select
' PDF input box
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'folder local
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'Arrange le nom
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'Créer un nom spécifique de fichier et pdf
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'Choisir le répertoire
myFile = Application.GetSaveAsFilename _
(InitialFileName:=Sheets("Filtre").Range("A18") & "_" & Sheets("Filtre").Range("C22") & Sheets("Filtre").Range("D22"), _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and FileName to save")
'export PDF
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'confirmation message
MsgBox "Le fichier PDF est Créé" _
& vbCrLf _
& myFile
End If
exitHandler:
Sheets("Intro").Select
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
merci !
Salut Dawid92
Oui, tu peux regarder dans les sujets similaires en bas de cette page
A+
Merci
Re bonjour
Alors j'ai réussi une première partie, le mail, le pdf fonctionne quand le nom du fichier et défini et reste fixe.
Mais j'aimerai que le nom du fichier puisse changer et être envoyer automatiquement.
Sub Macro1()
'
' Macro1 Macro
'
'
Dim myfile As String
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim olFormatHTML As String
myfile = Sheets("Filtre").Range("A18") & "_" & Sheets("Filtre").Range("C22") & Sheets("Filtre").Range("D22")
Sheets(Array("CAgen", "CAgen_Mois", "CA_invoice", "Catalogue")).Select
ChDir "W:\David\Email"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, IncludeDocProperties _
:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
FileAttach = "myfile"
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
strbody = "Information sur la mise à jour"
On Error Resume Next
With OutMail
.To = Sheets("Filtre").Range("R18")
.BCC = ""
.Subject = "Djeco statistics "
.BodyFormat = olFormatHTML
.HTMLBody = "Bonjour Please find attached statistics for the month, David"
.Attachments.Add enregistrement2_PDF
.Attachments.Add (FileAttach)
.OriginatorDeliveryReportRequested = False
.ReadReceiptRequested = False
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'retour
Worksheets("Intro").Activate
Range("A1").Select
End Sub
merci
Salut Dawid
C'est presque parfait
Il faut juste remplacer
FileAttach = "myfile"
Par
FileAttach = MyFile & ".pdf"
Il faut supprimer les guillemets autour de ta variable
A+
merci beaucoup Bruno
ça ouvre outlook malheureusement, la pièce jointe ne s'attache pas
Je remets le code complet au cas ou
Sub Email()
Dim Myfile As String
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim olFormatHTML As String
Myfile = Sheets("Filtre").Range("A18") & "_" & Sheets("Filtre").Range("C22") & Sheets("Filtre").Range("D22")
Sheets(Array("CAgen", "CAgen_Mois", "CA_invoice", "Catalogue")).Select
ChDir "W:\David\Email"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Myfile, Quality:=xlQualityStandard, IncludeDocProperties _
:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
FileAttach = Myfile & ".pdf"
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
strbody = "Information sur la mise à jour"
On Error Resume Next
With OutMail
.To = Sheets("Filtre").Range("R18")
.BCC = ""
.Subject = "Statistics of the months "
.BodyFormat = olFormatHTML
.HTMLBody = "Bonjour Please find attached statistics for the month, David"
.Attachments.Add enregistrement2_PDF
.Attachments.Add (FileAttach)
.OriginatorDeliveryReportRequested = False
.ReadReceiptRequested = False
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
'retour
Worksheets("Intro").Activate
Range("A1").Select
End Sub
J'avoue que je suis perdu...
merci
Bruno merci !
J'ai trouvé tout la finalité, il fallait mettre le chemin complet
FileAttach = "W:\David\Email\" & Myfile & ".pdf"
Merci encore pour cette aide précieuse !