Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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

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:

ilyess30

XLDnaute Nouveau
Ajouter :
Dim xOutlookObjAs As Object
 

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
@+
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…