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
Si je n'étais pas novice je ne demanderai pas d'aide vous savez
J'ai mis "ThisWorkbook.Path " dans mon chemin met cela me donne une erreur ligne 4. Je suppose que j'ai mal fait..
VB:
 xFolder = xFolder & "\" & ThisWorkbook.Path & "\" & 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
 
Dernière édition:

cp4

XLDnaute Barbatruc
Si je n'étais pas novice je ne demanderai pas d'aide vous savez
J'ai mis "ThisWorkbook.Path " dans mon chemin met cela me donne une erreur ligne 4. Je suppose que j'ai mal fait..
VB:
 xFolder = xFolder & "\" & ThisWorkbook.Path & "\" & 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
Vous auriez dû joindre un petit fichier.
Si je n'étais pas novice je ne demanderai pas d'aide vous savez
Donc le code édité sur xld n'est pas de vous (généralement on se tutoie sur ce forum).
Je suis un peu débordé ces jours-ci. Dans le code édité, vous choisissiez le chemin où enregistrer et vous faisiez une vérification sur l'existence du fichier, le supprimer au cas.

Là, vous voulez enregistrer la feuille active dans le même répertoire du fichier excel, avec un nom prédéfini?
je reviens plus tard, désolé.
 

Fabrice16ct

XLDnaute Nouveau
Vous auriez dû joindre un petit fichier.

Donc le code édité sur xld n'est pas de vous (généralement on se tutoie sur ce forum).
Je suis un peu débordé ces jours-ci. Dans le code édité, vous choisissiez le chemin où enregistrer et vous faisiez une vérification sur l'existence du fichier, le supprimer au cas.

Là, vous voulez enregistrer la feuille active dans le même répertoire du fichier excel, avec un nom prédéfini?
je reviens plus tard, désolé.
Oui c'est ce que j'aimerais!
merci à toi
 

cp4

XLDnaute Barbatruc
à chaque exécution du code le fichier pdf précédemment enregistré sera écrasé.
J'ai supprimé les lignes non nécessaires et je n'ai rien touché côté outlook.
J'ai fait une grossière erreur pour l'antislash du système: Application.PathSeparator au lieu de PathSeparator
Code:
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

   xFolder = ThisWorkbook.Path & Application.PathSeparator & xSht.Name & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D6") & ".pdf"     '/ = mauvais charactère
'xFolder = ThisWorkbook.Path & Application.PathSeparator & xSht.Name

     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
 

Fabrice16ct

XLDnaute Nouveau
J'ai changé Application.PathSeparator contre PathSeparator, mais j'ai hélas la même erreur en plus j'ai 2 fois le nom de l'onglet
VB:
 xFolder = ThisWorkbook.Path & PathSeparator & xSht.Name & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D6") & ".pdf"
 
Dernière édition:

cp4

XLDnaute Barbatruc
J'ai changé Application.PathSeparator contre PathSeparator, mais j'ai hélas la même erreur en plus j'ai 2 fois le nom de l'onglet
VB:
 xFolder = ThisWorkbook.Path & PathSeparator & xSht.Name & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D6") & ".pdf"
Si pour toi cette ligne de code (qui en commentaire, ne s’exécute pas)
'xFolder = ThisWorkbook.Path & Application.PathSeparator & xSht.Name
Je l'ai utilisé pour faire un test sr mon pc.

tu peux remplacer Application.PathSeparator par "\".
xFolder représente le chemin complet où sera enregistré le fichier pdf avec le nom prédéfini récupéré de 2 cellules et son extension.
Je vois qu'à la fin de la ligne, il y a une erreur c'est .pdf au lieu de ,pdf
 

Fabrice16ct

XLDnaute Nouveau
J'ai toujours le même problème avec "%20" alors j'ai ajouté une cellule caché en B5 dans mon fichier Excel qui donne "Ordre-de-mission" et cela fonctionne.
Est-ce que j'ai bien fait ?
Par contre maintenant j'ai le problème avec la dernière cellule D6, qui est le nom et prénom qu'on choisit vis-à-vis d'un menu déroulant. Je vais essayer de faire la même chose sur le script comme en B5.
Qu'est-ce que tu en penses?
Si je mets une virgule à la place du “.PDF” cela me met erreur de téléchargement , alors j'ai laissé “.PDF”

VB:
xFolder = ThisWorkbook.Path & Application.PathSeparator & Replace(Worksheets("Ordre de mission").Range("B5").Value, "/", "-") & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D6") & ".pdf"
 

cp4

XLDnaute Barbatruc
J'ai toujours le même problème avec "%20" alors j'ai ajouté une cellule caché en B5 dans mon fichier Excel qui donne "Ordre-de-mission" et cela fonctionne.
Est-ce que j'ai bien fait ?
Par contre maintenant j'ai le problème avec la dernière cellule D6, qui est le nom et prénom qu'on choisit vis-à-vis d'un menu déroulant. Je vais essayer de faire la même chose sur le script comme en B5.
Qu'est-ce que tu en penses?
Si je mets une virgule à la place du “.PDF” cela me met erreur de téléchargement , alors j'ai laissé “.PDF”

VB:
xFolder = ThisWorkbook.Path & Application.PathSeparator & Replace(Worksheets("Ordre de mission").Range("B5").Value, "/", "-") & "_" & Replace(Sheets("Ordre de mission").Range("B11").Value, "/", "-") & "_" & Range("D6") & ".pdf"
Envoie ton fichier de travail sans données personnelles. On ne peut pas deviner ce que tu as sur ton fichier.
 

Fabrice16ct

XLDnaute Nouveau
Envoie ton fichier de travail sans données personnelles. On ne peut pas deviner ce que tu as sur ton fichier.
Ce que je comprends pas c'est que dans le fichier que je viens de t'envoyer “Classeur2” Il n'y a plus la séparation entre les mots avec “%20”dans le nom de fichier PDF
C'est bizarre non?
Par contre dans le fichier original ”%20” est toujours présent
 

Pièces jointes

  • Classeur2.xlsm
    42.7 KB · Affichages: 2

Discussions similaires

Statistiques des forums

Discussions
312 209
Messages
2 086 271
Membres
103 168
dernier inscrit
isidore33