Option Explicit
Private Function CreationDossier(ByVal sChemin As String) As Boolean
Dim i As Long, sTmp As String, Ar() As String
If InStr(sChemin, ":") = 0 Then
Ar = Split(CurDir & "\" & sChemin, "\")
Else
Ar = Split(sChemin, "\")
End If
sTmp = Ar(0)
ChDrive sTmp
For i = LBound(Ar) + 1 To UBound(Ar)
If Ar(i) <> "" Then
sTmp = sTmp & "\" & 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
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 Tst()
Dim LaDate As String, Periode As String, LeRep As String
Dim sDossier As String, sFichier As String
LaDate = Format(Date, "yyyymmdd")
Periode = Worksheets("Rapport Actia").Range("p2").Text
If NomFichierValide(Periode) = False Then
MsgBox "Nom de fichier invalide !", vbOKCancel + vbCritical
With Worksheets("Rapport Actia")
.Activate
.Range("p2").Select
End With
Exit Sub
End If
Application.ScreenUpdating = False
LeRep = ThisWorkbook.Path
sDossier = "Historique"
CreationDossier (LeRep & "\" & sDossier)
sFichier = LaDate & " - Conso gasoil - Période " & Periode & ".pdf"
sFichier = RenommerFichier(LeRep & "\" & sDossier, sFichier)
Graph1.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sFichier, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
Application.ScreenUpdating = True
End Sub