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

Mika07 · 13 Janvier 2023

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

Mika07 · 16 Janvier 2023

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 · 13 Janvier 2023

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

kiki29 · 13 Janvier 2023

Salut, fouiller dans le site de Ron de Bruin , accessoirement si curieux voir Liste Contributions PDF

Mika07 · 13 Janvier 2023

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 !

TooFatBoy · 13 Janvier 2023

Bonjour,

Ca ne fonctionne pas sans passer par le Select ?

kiki29 · 13 Janvier 2023

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 · 13 Janvier 2023

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 · 13 Janvier 2023

Mika07 à dit:
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.

Mika07 · 14 Janvier 2023

J'ai fais un exemple, cela me génére un pdf blanc...

kiki29 · 14 Janvier 2023

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 !

TooFatBoy · 14 Janvier 2023

Mika07 à dit:
J'ai fais un exemple, cela me génére un pdf blanc...

Ben... avec des feuilles vides, c'est normal.
Ceci dit, tu as raison, seule la première feuille semble utilisée pour créer le pdf...

Et je me réponds à moi-même : non, sans le Select, ça ne fonctionne pas.

Bonne journée

Mika07 · 16 Janvier 2023

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 · 16 Janvier 2023

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 !

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

Mika07

XLDnaute Nouveau

Mika07

Oneida

XLDnaute Impliqué

kiki29

XLDnaute Barbatruc

Mika07

XLDnaute Nouveau

TooFatBoy

XLDnaute Barbatruc

kiki29

XLDnaute Barbatruc

Mika07

XLDnaute Nouveau

TooFatBoy

XLDnaute Barbatruc

Mika07

XLDnaute Nouveau

Pièces jointes

kiki29

XLDnaute Barbatruc

Pièces jointes

TooFatBoy

XLDnaute Barbatruc

Mika07

XLDnaute Nouveau

Mika07

XLDnaute Nouveau

Discussions similaires