XL 2016 Export PDF dans sous dossier

kiki29 à dit:

Salut, voir par ici

Cliquez pour agrandir...

kiki29 à dit:

Re, une recherche te donne ceci parmi une myriade

Cliquez pour agrandir...

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

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

Cliquez pour agrandir...