XL 2016 Macro "Enregister sous" au format PDF avec nom prédéfini

WoOdErOu

XLDnaute Nouveau
Bonjour à tous,

Je rencontre un problème, qui, je pense est plutôt simple mais sur lequel je bloque complètement.

Sur un bon de commande, j'ai deux boutons : 1 qui permet d'ouvrir la boîte de dialogue "Enregistrer sous" avec le nom du fichier prédéfini, et en format .xlsm. Il ne reste donc plus qu'à l'utilisateur de choisir le dossier dans lequel il veut le ranger.

Le code est le suivant :

VB:
Sub enregistrersous()
Dim NomFichier As String, extension As String
    NomFichier = Range("M4")
    extension = ".xlsm"
    Application.Dialogs(xlDialogSaveAs).Show NomFichier & extension
End Sub


J'essaye donc de faire exactement la même chose pour le deuxième bouton, mais avec un export en format PDF. Après maintes tentatives, j'en suis pour le moment à ce code-là :

VB:
Sub enregistrersousPDF()
Dim NomFichier As String

  NomFichier = Range("M4") & ".pdf"
  Sheets("Bon de Commande").ExportAsFixedFormat Type:=xlTypePDF, Filename:=NomFichier, _
                                          Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                          IgnorePrintAreas:=False, OpenAfterPublish:=True

End Sub


Il fait tout ce que je lui demande, hormis qu'il enregistre automatiquement le PDF dans le même dossier que le fichier Excel d'origine. J'imagine que je dois coller cette ligne de code
VB:
Application.Dialogs(xlDialogSaveAs).Show NomFichier & extension
quelque part, mais je ne sais pas où!!

D'avance, merci pour votre aide, et très bonne journée.

Bien à vous,

WoOdErOu
 

kiki29

XLDnaute Barbatruc
Salut, à toi de tester plus à fond, et adapter si besoin à ton contexte.
VB:
Option Explicit

Sub EnregistrerSous()
Dim sNomfichier As String, sExt1 As String, sExt2 As String
Dim sChemin As String, oNomFichier As Variant
Dim pos As Long, sFichierFinal As String

    ChDir ThisWorkbook.Path

    sNomfichier = Feuil1.Range("M4")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Feuil1.Range("M4").Select
        MsgBox "Nom de fichier invalide !", vbCritical + vbOKOnly
        Exit Sub
    End If

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sNomfichier, _
                                                fileFilter:="Fichiers Excel (*" & sExt1 & ", *" & sExt1)
    If oNomFichier <> False Then
        pos = InStrRev(oNomFichier, "\")
        sChemin = Left$(oNomFichier, pos - 1)
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt1)
        ActiveWorkbook.SaveCopyAs Filename:=sFichierFinal
        
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Feuil2.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=sFichierFinal, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=True
    End If
End Sub

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const CaracInterdits As String = """*/:<>?[\]|"

    NomFichierValide = True
    For i = 1 To Len(CaracInterdits)
        If InStr(sChaine, Mid$(CaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function
 
Dernière édition:

kiki29

XLDnaute Barbatruc
Une version qui tient compte des doublons éventuels, tjs à tester plus à fond
VB:
Option Explicit

Sub EnregistrerSous()
Dim sNomfichier As String, sExt1 As String, sExt2 As String
Dim sChemin As String, oNomFichier As Variant
Dim pos As Long, sFichierFinal As String

    ChDir ThisWorkbook.Path

    sNomfichier = Feuil1.Range("M4")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Feuil1.Range("M4").Select
        MsgBox "Nom de fichier invalide !", vbCritical + vbOKOnly
        Exit Sub
    End If

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sNomfichier, _
                                                fileFilter:="Fichiers Excel (*" & sExt1 & ", *" & sExt1)
    If oNomFichier <> False Then
        pos = InStrRev(oNomFichier, "\")
        sChemin = Left$(oNomFichier, pos - 1)
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt1)
        ActiveWorkbook.SaveCopyAs Filename:=sFichierFinal
        
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Feuil2.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=sFichierFinal, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=True
    End If
End Sub

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const CaracInterdits As String = """*/:<>?[\]|"

    NomFichierValide = True
    For i = 1 To Len(CaracInterdits)
        If InStr(sChaine, Mid$(CaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function
 

Pièces jointes

  • Save Xlsm PDF.png
    Save Xlsm PDF.png
    9.4 KB · Affichages: 45
Dernière édition:

murainesouspatate

XLDnaute Occasionnel
Une version qui tient compte des doublons éventuels, tjs à tester plus à fond
VB:
Option Explicit

Sub EnregistrerSous()
Dim sNomfichier As String, sExt1 As String, sExt2 As String
Dim sChemin As String, oNomFichier As Variant
Dim pos As Long, sFichierFinal As String

    sNomfichier = Feuil1.Range("M4")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Feuil1.Range("M4").Select
        MsgBox "Nom de fichier invalide !", vbCritical + vbOKOnly
        Exit Sub
    End If

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sNomfichier, _
                                                fileFilter:="Fichiers Excel (*" & sExt1 & ", *" & sExt1)
    If oNomFichier <> False Then
        pos = InStrRev(oNomFichier, "\")
        sChemin = Left$(oNomFichier, pos - 1)
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt1)
        ActiveWorkbook.SaveAs Filename:=sFichierFinal, _
                              FileFormat:=xlOpenXMLWorkbookMacroEnabled
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Feuil2.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=sFichierFinal, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=True
        ActiveWorkbook.Close True
    End If
End Sub

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const CaracInterdits As String = """*/:<>?[\]|"

    NomFichierValide = True
    For i = 1 To Len(CaracInterdits)
        If InStr(sChaine, Mid$(CaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function
Bonjour, super boulot , merci beaucoup, je vais tester cela car je n'y avait pas pensé..... bonne journée !
 

kiki29

XLDnaute Barbatruc
Salut, juste pour info Feuil1 et Feuil2 sont les CodeNames des feuilles concernées et non les noms d'onglets.
Cela permet d'insérer des feuilles, de les déplacer, de modifier les noms d'onglets, ceci sans avoir à retoucher au code VBA.

Inutile de fonctionner par psittacisme et de recopier un code caduque puisque modifié entre temps. Cela ne fait qu'encombrer inutilement un espace visuel restreint.
 
Dernière édition:

Discussions similaires

Membres actuellement en ligne

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib