XL 2019 Excel - générer .PDF avec envoie mail

Mika07

XLDnaute Nouveau
Bonjour,

J'utilise cette macro depuis longtemps.
Cela fonctionne parfaitement quand le bouton se trouve sur un onglet "Feuil1"
La macro génère un PDF et un mail de l'onglet "Feuil1".

Maintenant j'essaye de mettre mon bouton dans un autre onglet "Feuil4" pour que quand j'appuie dessus le PDF généré soit les "Feuil1 à 3".
Tout en gardant le mail.


Code:
Sub Saveandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + Range("C6") + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .display
        .TO = Range("C3")
        .CC = Range("C4")
        .BCC = Range("C5")
        .Subject = Range("C6")
        .HTMLBody = "<FONT size=3>" & Range("C7") & "<br>" _
                    & "<br>" _
                    & Range("C8") & "<br>" _
                    & Range("C9") & "<br>" & .HTMLBody
        .Attachments.Add xFolder

        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
 
Dernière édition:
Solution
Bonjour,

Merci à vous pour votre aide.

J'ai mis le code sur mon fichier mais cela me met une erreur sur la ligne :
Code:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard, OpenAfterPublish:=True

Alors que sur le fichier test ca fonctionne bien.

En cherchant un peu, quand je change le Filename, ca passe mais j'ai une erreur plus loin.

Code:
Sub Saveandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox...

Oneida

XLDnaute Impliqué
Bonjour,

Sub enr_feuille_PDF()
'ici plusieur feuille
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
Selection.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:="C:\TestFolder\temp.pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub
 

Mika07

XLDnaute Nouveau
Super,

Merci beaucoup.

En remplaçant :
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
par
ThisWorkbook.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard, OpenAfterPublish:=True

Ca fonctionne nickel 👍

Bonne soirée !
 

kiki29

XLDnaute Barbatruc
Salut, ne pas omettre de désélectionner les feuilles après ActiveSheet.ExportAsFixedFormat via Sheets("Sheet1").Select par exemple , sinon si tu saisis qqch sur l'une d'entre elles cela se trouvera reporté sur toutes les autres ...
 

Mika07

XLDnaute Nouveau
J’avais essayé avec « Sélection » mais cela m’imprimait 4 feuilles blanches avec un carré noir sur la 1er page.
En mettant cela ça a fonctionné de suite….mais plus maintenant. Je ne comprends pas.
En ayant sauvegardé puis en relançant le fichier, cela me met une erreur sur la ligne. Même en mettant « sélection ».
 

TooFatBoy

XLDnaute Barbatruc
J’avais essayé avec « Sélection » mais cela m’imprimait 4 feuilles blanches avec un carré noir sur la 1er page.
En mettant cela ça a fonctionné de suite….mais plus maintenant. Je ne comprends pas.
En ayant sauvegardé puis en relançant le fichier, cela me met une erreur sur la ligne. Même en mettant « sélection ».
Du coup, si tu essayes comme je le disais plus haut, sans le Select, tu n'auras peut-être plus ce problème, et ça répondra à ma question. ;)
 
Dernière édition:

kiki29

XLDnaute Barbatruc
Salut, tout simplement
VB:
ActiveSheet.ExportAsFixedFormat ....
pour remplacer Selection.ExportAsFixedFormat ......

voir Impression de certaines Feuilles d'un classeur via un tableau dans un seul Pdf résultant
en bas du tout 1er post datant de 2007 de Liste Contributions PDF

@Mika07 : Balise ton code !
 

Pièces jointes

  • 1.png
    1.png
    19.4 KB · Affichages: 18
  • Code XLD.png
    Code XLD.png
    4.8 KB · Affichages: 17
Dernière édition:

Mika07

XLDnaute Nouveau
Bonjour,

Merci à vous pour votre aide.

J'ai mis le code sur mon fichier mais cela me met une erreur sur la ligne :
Code:
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard, OpenAfterPublish:=True

Alors que sur le fichier test ca fonctionne bien.

En cherchant un peu, quand je change le Filename, ca passe mais j'ai une erreur plus loin.

Code:
Sub Saveandsend()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
   Exit Sub
End If
xFolder = xFolder + "\" + Range("C6") + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "if you don't overwrite the existing PDF, I can't continue." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Unable to delete existing file.  Please make sure the file is not open or write protected." _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
        Exit Sub
    End If
End If


Set xUsedRng = xSht.UsedRange

If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    ThisWorkbook.Sheets(Array("Page de présentation", "Renseignements", "Etat livraison", "Etat installation")).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard, OpenAfterPublish:=True
    
    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .display
        .TO = Range("C5")
        .CC = Range("C6")
        .BCC = Range("C7")
        .Subject = Range("C8")
        .HTMLBody = "<FONT size=3>" & Range("C9") & "<br>" _
                    & "<br>" _
                    & Range("C10") & "<br>" _
                    & Range("11") & "<br>" & .HTMLBody
        .Attachments.Add xFolder
                
        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "The active worksheet cannot be blank"
  Exit Sub
End If
End Sub
 

Mika07

XLDnaute Nouveau
J'ai trouvé mon erreur, désolé pour le dérangement !

J'avais oublié de remettre la bonne cellule pour le titre du PDF. Cela me générait aucun PDF car la casse était vide.

Code:
xFolder = xFolder + "\" + Range("C6") + ".pdf"

Je clôt le sujet.

Merci beaucoup, bonne journée ! :)
 

Discussions similaires

Réponses
6
Affichages
269
Réponses
17
Affichages
1 K