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

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

F

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:
Trier par date Trier par votes
F

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:
Vote positif 0 Vote négatif

cp4

XLDnaute Barbatruc
Vous auriez dû joindre un petit fichier.
Fabrice16ct à dit:
Si je n'étais pas novice je ne demanderai pas d'aide vous savez
Cliquez pour agrandir...
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é.
 
Vote positif 0 Vote négatif
F

Fabrice16ct

XLDnaute Nouveau
Oui c'est ce que j'aimerais!
merci à toi
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
F

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:
Vote positif 0 Vote négatif

cp4

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
F

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"
 
Vote positif 0 Vote négatif

cp4

XLDnaute Barbatruc
Envoie ton fichier de travail sans données personnelles. On ne peut pas deviner ce que tu as sur ton fichier.
 
Vote positif 0 Vote négatif
F

Fabrice16ct

XLDnaute Nouveau
cp4 à dit:
Envoie ton fichier de travail sans données personnelles. On ne peut pas deviner ce que tu as sur ton fichier.
Cliquez pour agrandir...
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: 5
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

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
441
Mika07
M
Y
  • Question
XL 2016 sélection du dernier fichier modifié dans un dossier+ pièce jointe
Réponses
1
Affichages
467
kiki29
A
  • Question
Microsoft 365 Génération d'une feuille en Pdf et envoie par outlook
Réponses
5
Affichages
1 K
patricktoulon
Y
  • Question
XL 2013 Envoie de P-J sil existe par mail Macro VBA
Réponses
1
Affichages
677
kiki29
M
  • Résolu(e)
XL 2016 mail en automatique dans excel destinataire en fonction de la valeur d une cellule
Réponses
11
Affichages
1 K
mathieu20
M
  • Résolu(e)
XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire
Réponses
5
Affichages
536
Nico2978
M
  • Question
XL 2013 VBA-Envoyer par email "Plage de cellules collée dans un nouveau classeur en gardant formules de certaines cellules
Réponses
2
Affichages
852
MONTREAL2020
M
C
  • Question
XL 2013 Insérer lien hypertexte cliquable dans mail envoyé par VBA
Réponses
0
Affichages
3 K
Claggan
C
  • Question
Petit prob d'envoie de courriels
Réponses
2
Affichages
1 K
Valtrase
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…