Microsoft 365 Génération d'une feuille en Pdf et envoie par outlook

A

Adrien.dub

XLDnaute Nouveau
Bonjour,

N'ayant pas les connaissance pour la modification d'un code en fonction de mes besoins, j'aimerais un coups de mains pour m'aiguiller sur les modification à apporter.
Je souhaite faire l'extraction d'une feuille active par pression d'un bouton sur la dite feuille pour en générer un Pdf et ensuite envoyer le pdf par mail en fonction des email mis dans la feuille paramètre.
Je bloque actuellement sur la façon de procéder pour nommer mon fichier en fonction de plusieurs cellule bien spécifique qui sont dans l'ordre ("D2"), ("C5") et ("E5").

Voici mon code actuel ainsi que le fichier type.

VB: 
Sub savepdfemail()
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 + "\" + xSht.Name + ".pdf"

'Vérifier si le fichier existe déjà et demande de suppression
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " existe déjà." & vbCrLf & vbCrLf & "Voulez-vous écraser le fichier précédent", _
                      vbYesNo + vbQuestion, "Fichier existant")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "Vous ne pourrez continuer si vous n'acceptez pas" _
                    & vbCrLf & vbCrLf & "Appuyer sur Ok pour quitter.", vbCritical, "Annuler"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Impossible d'écraser le fichier, merci de vérifier si celui-ci n'est pas ouvert" _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Impossible de supprimer le fichier"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Sauvegarde sous format PDF
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
    
    'Création du mail outlook
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    Set emailTO = Worksheets("parametre").Range("C8")
    Set emailCC = Worksheets("parametre").Range("C9")
    Set emailCC1 = Worksheets("parametre").Range("C10")
    Set emailCC2 = Worksheets("parametre").Range("C11")
    Set emailCC3 = Worksheets("parametre").Range("C12")
    Set emailCC4 = Worksheets("parametre").Range("C13")
    Set emailCC5 = Worksheets("parametre").Range("C14")
    With xEmailObj
        .Display
        .To = emailTO
        .CC = emailCC + "; " + emailCC1 + "; " + emailCC2 + "; " + emailCC3 + "; " + emailCC4 + "; " + emailCC5
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
            
        End If
    End With
Else
  MsgBox "La feuille active ne peux être vierge"
  Exit Sub
End If
End Sub
 

Pièces jointes

  • fichiertest.xlsm
    56.6 KB · Affichages: 9
Trier par date Trier par votes
kiki29

kiki29

XLDnaute Barbatruc
Voir via Liste Contributions PDF

pour l'envoi mail voir CDO
sans oublier RdB
Pourquoi utiliser le code CDO au lieu de l'automatisation Outlook ou SendMail dans VBA.

1 : Peu importe le programme de messagerie que vous utilisez (il utilise uniquement le serveur SMTP).
2 : Peu importe la version d'Office que vous utilisez (97…2016)
3 : Vous pouvez envoyer une plage/feuille dans le corps du courrier (certains programmes de messagerie ne peuvent pas le faire)
4: Vous pouvez envoyer n'importe quel fichier que vous aimez (fichiers Word, PDF, PowerPoint, TXT,….)
5 : Aucun avertissement de sécurité, vraiment génial si vous envoyez beaucoup de courrier en boucle.
 
Dernière édition:
Vote positif 0 Vote négatif
I

ilyess30

XLDnaute Nouveau
Adrien.dub à dit:
Bonjour,

N'ayant pas les connaissance pour la modification d'un code en fonction de mes besoins, j'aimerais un coups de mains pour m'aiguiller sur les modification à apporter.
Je souhaite faire l'extraction d'une feuille active par pression d'un bouton sur la dite feuille pour en générer un Pdf et ensuite envoyer le pdf par mail en fonction des email mis dans la feuille paramètre.
Je bloque actuellement sur la façon de procéder pour nommer mon fichier en fonction de plusieurs cellule bien spécifique qui sont dans l'ordre ("D2"), ("C5") et ("E5").

Voici mon code actuel ainsi que le fichier type.

VB: 
Sub savepdfemail()
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 + "\" + xSht.Name + ".pdf"

'Vérifier si le fichier existe déjà et demande de suppression
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " existe déjà." & vbCrLf & vbCrLf & "Voulez-vous écraser le fichier précédent", _
                      vbYesNo + vbQuestion, "Fichier existant")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "Vous ne pourrez continuer si vous n'acceptez pas" _
                    & vbCrLf & vbCrLf & "Appuyer sur Ok pour quitter.", vbCritical, "Annuler"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Impossible d'écraser le fichier, merci de vérifier si celui-ci n'est pas ouvert" _
                    & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Impossible de supprimer le fichier"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Sauvegarde sous format PDF
    xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
   
    'Création du mail outlook
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    Set emailTO = Worksheets("parametre").Range("C8")
    Set emailCC = Worksheets("parametre").Range("C9")
    Set emailCC1 = Worksheets("parametre").Range("C10")
    Set emailCC2 = Worksheets("parametre").Range("C11")
    Set emailCC3 = Worksheets("parametre").Range("C12")
    Set emailCC4 = Worksheets("parametre").Range("C13")
    Set emailCC5 = Worksheets("parametre").Range("C14")
    With xEmailObj
        .Display
        .To = emailTO
        .CC = emailCC + "; " + emailCC1 + "; " + emailCC2 + "; " + emailCC3 + "; " + emailCC4 + "; " + emailCC5
        .Subject = xSht.Name + ".pdf"
        .Attachments.Add xFolder
        If DisplayEmail = False Then
           
        End If
    End With
Else
  MsgBox "La feuille active ne peux être vierge"
  Exit Sub
End If
End Sub
Cliquez pour agrandir...
Ajouter :
Dim xOutlookObjAs As Object
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
Bonjour
j'ai revu en totalité ton code
j'ai fait simple
la boite de dialogue c'est la "enregistrer sous " avec le nom de fichier prédéterminé
quand tu concactaine du texte (du string) evite les "+" utilise plutot "&"
je t'ai ajouté un petit message
je n'ai pas compris pourquoi en anglais mais bon j'ai continué sur la lancée
voilà
VB: 
Sub savepdfemail()
    Dim xSht As Worksheet, Nom$, FilePDF, Rep As VbMsgBoxResult, OK As Boolean, xOutlookObj As Object, xEmailObj As Object, DisplayEmail As Boolean

    Set xSht = ActiveSheet
    Nom = xSht.[D2] & " " & xSht.[c5] & " " & Format(xSht.[E5], "dd-mm-yyyy")
    OK = True
    DisplayEmail = True

    FilePDF = Application.GetSaveAsFilename(InitialFileName:=Nom, filefilter:="Pdf Files (*.pdf), *.pdf", Title:="ENREGISTREMENT DE LA FEUILLE EN PDF")
    'dialog to save filepdf
    If FilePDF = False Then
        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
    'if you dont press "Annuler"  then ok is true
    If Dir(FilePDF) <> "" Then
        Rep = MsgBox("This file exists, do you want to overwrite the existing one?", vbYesNo + vbExclamation, "Alert existing file")
        OK = Rep = vbYes
    End If
    'if ok is true then save  the pdffile with then variable name(nom)
    ' and open outlook
    If OK Then
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=FilePDF, Quality:=xlQualityStandard

        'Création du mail outlook
        Set xOutlookObj = CreateObject("Outlook.Application")
        Set xEmailObj = xOutlookObj.CreateItem(0)
        emailTO = Worksheets("parametre").Range("C8").Text
        emailCC = Worksheets("parametre").Range("C9").Text
        emailCC1 = Worksheets("parametre").Range("C10").Text
        emailCC2 = Worksheets("parametre").Range("C11").Text
        emailCC3 = Worksheets("parametre").Range("C12").Text
        emailCC4 = Worksheets("parametre").Range("C13").Text
        emailCC5 = Worksheets("parametre").Range("C14").Text
        With xEmailObj

            .To = emailTO
            .CC = emailCC + "; " + emailCC1 & "; " & emailCC2 & "; " & emailCC3 & "; " & emailCC4 & "; " & emailCC5
            .Subject = Nom

            .Attachments.Add FilePDF

            .body = "Hello, please find attached the [[" & xSht.[D2] & "]] for the night of" & xSht.[E5] & vbCrLf & _
                    "wishing you good reception"


            If DisplayEmail Then
                .Display
               'you cant see the outlook application
                Else
                '.send
            End If
        End With
    End If
End Sub
@+
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Résolu(e)
XL 2019 Excel - générer .PDF avec envoie mail
Réponses
12
Affichages
2 K
Mika07
M
M
  • Question
Microsoft 365 Joindre une copie de 2 feuilles Excel dans outlook
Réponses
0
Affichages
420
Mika07
M
F
  • Résolu(e)
XL 2019 Enregistrer sous la feuille active dans répertoire du fichier père en vba
2
Réponses
23
Affichages
1 K
Fabrice16ct
F
E
  • Question
Microsoft 365 GetFolder et Sharepoint
Réponses
3
Affichages
945
eric72
E
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
927
Nicolas JACQUIN
Nicolas JACQUIN
P
  • Question
Outlook Outlook imprimer mail et PJ en PDF
Réponses
2
Affichages
813
paulng
P
A
  • Question
XL 2021 comment convertir et enregistrer en pdf tout en conservant la date d'une textbox vba
Réponses
2
Affichages
436
AugusteP
A
B
  • Question
Microsoft 365 Envoi pièce jointe html avec Outlook en VBA
Réponses
5
Affichages
1 K
bennp
B
M
  • Question
Microsoft 365 VBA - Extraire tous les emails d'une cellule et les coller dans une autre feuille
Réponses
4
Affichages
747
mimich_88
M
N
  • Question
Microsoft 365 donner a ma feuille le nom de l'onglet avant envoi par mails
Réponses
2
Affichages
877
Nabster
N

Membres actuellement en ligne

13 membres et 379 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 714
Messages
2 112 140
Membres
111 436
dernier inscrit
jibusigor