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