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

kiki29 à dit:

Voir via Liste Contributions PDF

pour l'envoi mail voir CDO
sans oublier RdB

Cliquez pour agrandir...

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...