XL 2016 Impression feuille Excel en PDF

Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long

Const sDossier As String = "C:\...\...\...\...\Test Gestion"

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

Sub Effacer()
    Application.ScreenUpdating = False
    Feuil1.Range("C4:D4,H6:H119").ClearContents
    Application.ScreenUpdating = True
End Sub

Sub Impression()
Dim sExt As String, pos As Long, sChemin As String
Dim sNomFichier As String, oNomFichier As Variant
Dim sFichierFinal As String, sPre As String

    CreationDossier sDossier
   
    sPre = Feuil1.Range("C4") & " " & Feuil1.Range("B2") & " " & Feuil1.Range("E4")
    sNomFichier = sPre & " Dépenses.pdf"

    sExt = ".pdf"

    If NomFichierValide(sNomFichier) = False Then
        MsgBox "Nom de fichier invalide !", vbCritical + vbOKOnly
        Exit Sub
    End If

    ChDir sDossier

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sNomFichier, _
                                                fileFilter:="Fichiers PDF (*" & sExt & ", *" & sExt)
    If oNomFichier <> False Then
        pos = InStrRev(oNomFichier, "\")
        sChemin = Left$(oNomFichier, pos - 1)

        sFichierFinal = RenommerFichier(sChemin, sNomFichier)
        Masquer_lignes_Vides
        Masquer_lignes_120_128
        DoEvents
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=sFichierFinal, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=False
        Montrer_lignes_Vides
        Montrer_lignes_120_128
        DoEvents
        sNomFichier = sPre & " All" & " Dépenses.pdf"
        sFichierFinal = RenommerFichier(sChemin, sNomFichier)
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=sFichierFinal, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=False
    End If
End Sub

Private Sub Masquer_lignes_120_128()
    Feuil1.Rows("120:128").EntireRow.Hidden = True
End Sub

Sub Masquer_lignes_Vides()
Dim i As Long
    Application.ScreenUpdating = False
    For i = 6 To 119
        If Feuil1.Cells(i, 8).Value = "" Then
            Feuil1.Rows(i).EntireRow.Hidden = True
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Private Sub Montrer_lignes_120_128()
    Feuil1.Rows("120:128").EntireRow.Hidden = False
End Sub

Sub Montrer_lignes_Vides()
    Feuil1.Cells.EntireRow.Hidden = False
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