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

[WoOdErOu]

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 :

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à :

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

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]

Salut, à toi de tester plus à fond, et adapter si besoin à ton contexte.

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

 

[kiki29]

Une version qui tient compte des doublons éventuels, tjs à tester plus à fond

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

 

[murainesouspatate]

Une version qui tient compte des doublons éventuels, tjs à tester plus à fond

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]

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.