XL 2019 Enregistrer sous la feuille active dans répertoire du fichier père en vba

Fabrice16ct

XLDnaute Nouveau
Bonjour,
J'ai une macro qui envoie un mail via Outlook et qui me demande à chaque fois ou enregistrer la feuille active pour la transformer en PDF et enregistrer.
J'aimerais qu'elle enregistre automatiquement dans le répertoire/ dossier ou il y a le fichier Excel du dit document
Es ce que cela est possible
Merci pour votre aide

VB:
Sub Ordre_de_mission()

     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 " Choisir un dossier dans lequel enregistrer le PDF." & vbCrLf & vbCrLf & " Appuyez sur OK pour quitter. FH", vbCritical, " Doit spécifier le dossier de destination "
          Exit Sub
   
     End If
   
     xFolder = xFolder & "\" & xSht.Name & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D6") & ".pdf"      '/ = mauvais charactère

     'Check if file already exist
     If Len(Dir(xFolder)) > 0 Then
          xYesorNo = MsgBox(xFolder & vbCrLf & vbCrLf & " le nom du fichier existe déjà. " & vbCrLf & vbCrLf & " Voulez-vous le remplacer ? FH", _
                            vbYesNo + vbQuestion, " File Exists ")
          On Error Resume Next
          If xYesorNo = vbYes Then
               Kill xFolder
          Else
               MsgBox " Si vous ne remplacez pas le PDF existant, je ne peux pas continuer." _
                      & vbCrLf & vbCrLf & " Appuyez sur OK pour quitter. FH", vbCritical, " Quitter "
               Exit Sub
          End If
          If Err.Number <> 0 Then
               MsgBox " Impossible de supprimer le fichier existant. Veuillez vous assurer que le fichier n’est pas ouvert ou protégé en écriture. " _
                      & vbCrLf & vbCrLf & " Appuyez sur OK pour quitter. FH", vbCritical, " Impossible de supprimer le fichier "
               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("A1")
               .CC = Range("A3")
               .Display                      ' afficher le mail avant de l’envoyer sinon placer send pour envoyer
               .Subject = Range("A5") & " " & Range("C16") & " - Déplacement prévu pour le " & Format(Range("D2"), "dd/mm/yy hh:mm")
               .HTMLBody = "<font face=""Arial""><font size=""10px"">" & "<U>Objet :</U>" & vbCrLf & vbCrLf & "<font color=#305496>" & Range("A5") & vbCrLf & vbCrLf & Range("C16") & vbCrLf & vbCrLf & "- Déplacement prévu pour le " & Format(Range("D2").Value, "dd/mm/yy hh:mm") & "." & "</font>" _
                           & "<br>" & "<br>" & Range("D1") & vbCrLf & vbCrLf & Range("E1") & Range("F1") & "<br>" & "<br>" & Range("A10") & "<br>" & "<br>" & Range("C6") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("D6") & "</font>" _
                           & "<br>" & Range("A7") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("C7") & "</font>" & "<br>" & Range("A8") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("C8") & "</font>" _
                           & "<br>" & Range("A9") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("B9") & "</font>" & "<br>" & Range("D9") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("E9") & "</font>" _
                           & "<br>" & "<br>" & Range("A11") & vbCrLf & vbCrLf & "<font color=#305496>" & Format(Range("B11").Value, "dd/mm/yy") & " pour " & Format(Range("B12"), "hh:mm") & "</font>" _
                           & "<br>" & Range("C11") & vbCrLf & vbCrLf & "<font color=#305496>" & Format(Range("D11").Value, "dd/mm/yy") & " vers " & Format(Range("D12"), "hh:mm") & "</font>" _
                           & "<br>" & Range("E11") & vbCrLf & vbCrLf & "<font color=#305496>" & [text(E12,"[hh]:mm")] & "</font>" & "<br>" & Range("F11") & vbCrLf & vbCrLf & "<font color=#305496>" & [text(F12,"[hh]:mm")] & "</font>" & "<br>" & "<br>" & Range("A13") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("B13") & "</font>" & "<br>" & Range("D13") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("E13") & "</font>" & "<br>" & "<br>" & Range("A14") _
                           & "<br>" & "<font color=#305496>" & IIf(Range("A15") = "", "", Range("A15") & "<br>") & IIf(Range("A16") = "", "", Range("A16") & "<br>") & IIf(Range("A17") = "", "", Range("A17") & "<br>") & IIf(Range("A18") = "", "", Range("A18") & "<br>") & IIf(Range("A19") = "", "", Range("A19") & "<br>") & "</font>" & "<br>" & Range("A21") & "<font color=#305496>" & Range("C21") & "</font>" _
                           & "<br>" & "<font color=#305496>" & IIf(Range("A22") = "", "", Range("A22") & "<br>") & IIf(Range("A23") = "", "", Range("A23") & "<br>") & "</font>" & "<font color=#305496>" & IIf(Range("A24") = "", "", Range("A24") & "<br>") & IIf(Range("A25") = "", "", Range("A25") & "<br>") & IIf(Range("A26") = "", "", Range("A26") & "<br>") & IIf(Range("A27") = "", "", Range("A27") & "<br>") & IIf(Range("A28") = "", "", Range("A28") & "<br>") & "</font>" & "<br>" & "</font>" & Range("A30") & vbCrLf & vbCrLf & "<font color=#305496>" & vbCrLf & vbCrLf & Range("B30") & "<br>" & Range("D30") & "</font>" _
                           & "<br>" & Range("D31") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("E31") & "</font>" & "<br>" & Range("D32") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("D33") & vbCrLf & vbCrLf & Range("E33") & vbCrLf & vbCrLf & Range("D34") & vbCrLf & vbCrLf & Range("E34") & vbCrLf & vbCrLf & Range("D35") & vbCrLf & vbCrLf & Range("E35") & vbCrLf & Range("D36") & vbCrLf & vbCrLf & Range("E36") & "</font>" _
                           & "<br>" & "<br>" & Range ("B32") & "<br>" & Range("B33") & vbCrLf & vbCrLf & "<font color=#305496>" & vbCrLf & vbCrLf & Range("C33") & "</font>" & "<br>" & Range("B34") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("C34") & "</font>" & "<br>" & Range("A35") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("B36") & " Km ->" & vbCrLf & vbCrLf _
                           & Format(Range("C36").Value, "00.00") & vbCrLf & vbCrLf & "€" & "</font>" & "<br>" & "<br>" & Range("A37") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("D37") & " Km" & "</font>" & "<br>" & "<br>" & Range("A39") & "<br>" & Range("B39") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("B40") & "</font>" _
                           & "<br>" & Range("C39") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("C40") & "</font>" & "<br>" & Range("D39") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("D40") & "</font>" & "<br>" & Range("E39") & vbCrLf & vbCrLf & "<font color=#305496>" & Range("E40") & "</font>" & "<br>" & "<br>" & Range("B10") & "<br>" & "<br>" & Range("C10") & vbCrLf & .HTMLBody _
 

               .Attachments.Add xFolder
                 If DisplayEmail = False Then

                    'au lieu de vraiment utiliser "Send", on utilise le "Display" et va simuler le raccoursi "CTRL+Enter" d'Outlook, ce qui est le "SEND"
                    .Display                 'no send
                    DoEvents
                    Application.Wait (Now + TimeSerial(0, 0, 5))     'donner un délai à Outlook pour bien préparer le mail
                    DoEvents
                    CreateObject("WScript.Shell").SendKeys ("^{Enter}"), True     '   "simuler" un raccourci "CTRL+Enter" (ceci n'est pas 100% sûr)
                    Application.Wait (Now + TimeSerial(0, 0, 2))     'donner un délai pour l'envoi
                    DoEvents
                    End If
          End With
     Else
          MsgBox " La feuille de calcul active ne peut pas être vide """
          Exit Sub
     End If

End Sub
 
Dernière édition:

Fabrice16ct

XLDnaute Nouveau
Ci-dessous cela vient s de mon fichier original
Captureerreur1.PNG
 

Fabrice16ct

XLDnaute Nouveau
J'ai été obligé de mettre cela dans le script pour éviter d'avoir les “%20” entre les mots du nom du PDF dans le fichier original. En tout cas maintenant je n'ai plus de problème!
Pourquoi j’ai des “%20” entre les mots dans mon fichier original?
En tout cas je te remercie pour l’aide que tu m'as apportée, grâce à toi cela fonctionne comme je voulais.
VB:
 xFolder = ThisWorkbook.Path & Application.PathSeparator & Replace(Worksheets("Ordre de mission").Range("B5").Value, " ", "-") & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D5") & ".pdf"
 

Fabrice16ct

XLDnaute Nouveau
Tu utilises peut-être des caractères spéciaux, lire ceci
J'ai contrôlé il n'y a pas de caractères spéciaux dans le nom du fichier et dans le nom de famille et le prénom.
J'ai contourné le problème en mettant une cellule cachée dans mon fichier ou j'intègre un petit tiret entre les mots du nom du fichier et une autre cellule pour le nom de famille et le prénom.
Cela fonctionne et j'en profite pour te remercier pour l'aide que tu m'as apportée sur mon problème et qui est maintenant résolu grâce à toi.
Merci et bonne journée à toi !👍👏
 

Discussions similaires

Statistiques des forums

Discussions
313 209
Messages
2 096 239
Membres
106 541
dernier inscrit
edf