Option Explicit
Dim sDossier As String
Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Integer, sTmp As String, Ar() As String
If InStr(sChemin, ":") = 0 Then
Ar = Split(CurDir & Application.PathSeparator & sChemin, Application.PathSeparator)
Else
Ar = Split(sChemin, Application.PathSeparator)
End If
sTmp = Ar(0)
ChDrive sTmp
For i = LBound(Ar) + 1 To UBound(Ar)
If Ar(i) <> "" Then
sTmp = sTmp & Application.PathSeparator & Ar(i)
On Error Resume Next
MkDir sTmp
On Error GoTo 0
End If
Next i
If Dir$(sChemin, vbDirectory) = vbNullString Then
CreationDossier = False
Else
CreationDossier = True
End If
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
Sub SavePDFs_03()
Dim sDossierPDFs As String, sFichier As String
Dim i As Long, iNb As Long
Dim Deb As Currency
Deb = Timer
Application.StatusBar = ""
Application.ScreenUpdating = False
iNb = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
sDossierPDFs = "PDFs Lignes Excel"
sDossier = ThisWorkbook.Path & Application.PathSeparator & sDossierPDFs
CreationDossier sDossier
For i = 2 To iNb
If NomFichierValide(Feuil1.Range("A" & i)) = False Then
Feuil1.Range("A" & i).Select
MsgBox "Nom de fichier invalide", vbOKOnly + vbCritical
Exit Sub
End If
Next i
For i = 2 To iNb
With Feuil1
.PageSetup.PrintArea = "$A$" & i & ":$T$" & i
.PageSetup.BlackAndWhite = True
sFichier = .Range("A" & i) & ".pdf"
.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sDossier & Application.PathSeparator & sFichier, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
Next i
Application.ScreenUpdating = True
Application.StatusBar = "Terminé : " & Format(Timer - Deb, "0.000 s")
End Sub
