Microsoft 365 Code VBA pour imprimer en pdf

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, Ar() As String

    ChDir ThisWorkbook.Path

    sNomfichier = Feuil1.Range("B5")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Feuil1.Range("B5").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)

        ReDim Ar(1) As String
        If Feuil1.Range("A1") = 1 And Feuil1.Range("A2") = 0 Then
            Ar(0) = Feuil1.Name
            Ar(1) = Feuil2.Name
        End If
        If Feuil1.Range("A1") = 0 And Feuil1.Range("A2") = 1 Then
            Ar(0) = Feuil1.Name
            Ar(1) = Feuil3.Name
        End If
        If Feuil1.Range("A1") = 1 And Feuil1.Range("A2") = 1 Then
            ReDim Ar(2) As String
            Ar(0) = Feuil1.Name
            Ar(1) = Feuil2.Name
            Ar(2) = Feuil3.Name
        End If
        If Feuil1.Range("A1") = 0 And Feuil1.Range("A2") = 0 Then
            MsgBox "Aucune feuille de sélectionnée !", vbCritical + vbOKOnly
            Feuil1.Range("A1").Select
            Exit Sub
        End If

        ThisWorkbook.SaveCopyAs Filename:=sFichierFinal
  
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Sheets(Ar).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=sFichierFinal, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=True
        Feuil1.Select
        Erase Ar
    End If
End Sub

Option Explicit

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

    ChDir ThisWorkbook.Path

    sNomfichier = Sheet1.Range("Z6")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Sheet1.Range("Z6").Select
        MsgBox "Invalid file name !", 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)

        Erase Ar
        ReDim Ar(1) As String
        If Sheet1.Range("AG11") = 1 And Sheet1.Range("AG12") = 0 Then
            Ar(0) = Sheet1.Name
            Ar(1) = Sheet2.Name
        End If
        If Sheet1.Range("AG11") = 0 And Sheet1.Range("AG12") = 1 Then
            Ar(0) = Sheet1.Name
            Ar(1) = Sheet3.Name
        End If
        If Sheet1.Range("AG11") = 1 And Sheet1.Range("AG12") = 1 Then
            ReDim Ar(2) As String
            Ar(0) = Sheet1.Name
            Ar(1) = Sheet2.Name
            Ar(2) = Sheet3.Name
        End If
        If Sheet1.Range("AG11") = 0 And Sheet1.Range("AG12") = 0 Then
            MsgBox "Choose a type of job !", vbCritical + vbOKOnly
            Sheet1.Range("B10").Select
            Exit Sub
        End If

        ThisWorkbook.SaveCopyAs Filename:=sFichierFinal
  
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Sheets(Ar).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=sFichierFinal, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=True
        Sheet1.Select
    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