XL 2016 Export PDF dans sous dossier

KTM

XLDnaute Impliqué
Bonsoir chers tous
je voudrais exporter ma plage A1:C10 au format PDF dans un sous dossier.
Ma macro doit:
- Créer un Dossier "Plage"
-Créer Un Sous dossier qui portera comme nom ma cellule E1
-Stocker mon Fichier PDF "TRIS" dans le Sous Dossier
J'ai élaboré ce qui suit mais je sais pas comment créer le sous dossier et le renommer
Merci de me guider
VB:
Sub SAVE()
Dim chemin As String
Dim fichier As String
             chemin = ThisWorkbook.Path & "\Plage\"
             If Dir(chemin, vbDirectory) = "" Then MkDir chemin
             With ActiveSheet
            
                .PageSetup.PrintArea = "$A$1:$C$10"
             fichier = .Range("A1")
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
             chemin & fichier, Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
          End With
End Sub
 

Pièces jointes

  • Classeur1.xlsm
    18.4 KB · Affichages: 8

KTM

XLDnaute Impliqué
Re, une recherche te donne ceci parmi une myriade
Encore Merci
J'ai essayé ce qui suit mais cela donne rien.
Prière me corriger
VB:
Sub SAVE()
Dim chemin As String
Dim fichier As String
             chemin = ThisWorkbook.Path & "\Plage\" & "\" & Cells(1, 5).Value & "\"
             If Dir(chemin, vbDirectory) = "" Then MkDir chemin
             With ActiveSheet
            
                .PageSetup.PrintArea = "$A$1:$C$10"
             fichier = .Range("A1")
                .ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
             chemin & fichier, Quality:=xlQualityStandard, _
             IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            
          End With
End Sub
 

kiki29

XLDnaute Barbatruc
Re, à toi de poursuivre en adaptant/élaguant pour ton contexte. A priori gère les doublons éventuels via un indice, vérifie la validité du nom de fichier.
VB:
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?[\]|"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, 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

Sub Sauvegarde()
Dim sDossier As String
Dim sFichier As String
    sDossier = ThisWorkbook.Path & "\" & "Plage" & "\" & shParam.Cells(1, 5).Text
    CreationDossier sDossier

    With Feuil1
        .PageSetup.PrintArea = "$A$1:$C$10"
        sFichier = .Range("A1")
        If NomFichierValide(sFichier) Then
            sFichier = .Range("A1") & ".pdf"
            sFichier = RenommerFichier(sDossier, sFichier)
            .ExportAsFixedFormat Type:=xlTypePDF, _
                                 Filename:=sFichier, _
                                 Quality:=xlQualityStandard, _
                                 IncludeDocProperties:=True, _
                                 IgnorePrintAreas:=False, _
                                 OpenAfterPublish:=False
        Else
            Feuil1.Range("A1").Select
            MsgBox "Nom de fichier invalide", vbOKOnly + vbInformation
        End If
    End With
End Sub
 

Pièces jointes

  • Sans titre-1.png
    Sans titre-1.png
    19.5 KB · Affichages: 6
Dernière édition:

KTM

XLDnaute Impliqué
Re, à toi de poursuivre en adaptant/élaguant pour ton contexte. A priori gère les doublons éventuels via un indice, vérifie la validité du nom de fichier.
VB:
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Option Explicit

Private Function CreationDossier(sDossier As String) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?[\]|"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, 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

Sub Sauvegarde()
Dim sDossier As String
Dim sFichier As String
    sDossier = ThisWorkbook.Path & "\" & "Plage" & "\" & shParam.Cells(1, 5).Text
    CreationDossier sDossier

    With Feuil1
        .PageSetup.PrintArea = "$A$1:$C$10"
        sFichier = .Range("A1")
        If NomFichierValide(sFichier) Then
            sFichier = .Range("A1") & ".pdf"
            sFichier = RenommerFichier(sDossier, sFichier)
            .ExportAsFixedFormat Type:=xlTypePDF, _
                                 Filename:=sFichier, _
                                 Quality:=xlQualityStandard, _
                                 IncludeDocProperties:=True, _
                                 IgnorePrintAreas:=False, _
                                 OpenAfterPublish:=False
        Else
            Feuil1.Range("A1").Select
            MsgBox "Nom de fichier invalide", vbOKOnly + vbInformation
        End If
    End With
End Sub
Merci
 

Discussions similaires

Statistiques des forums

Discussions
290 716
Messages
1 909 852
Membres
176 453
dernier inscrit
Nollan97
Haut Bas