Option Explicit
Sub MacroSauv_01()
Dim sDossier As String, sNom As String
Dim sFinal As String
sDossier = ThisWorkbook.Path
sNom = "Demande d'inscription et de réinscription.pdf"
sFinal = RenommerFichier(sDossier, sNom)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=sFinal, _
Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Sub MacroSauv_02()
Dim sDossier As String, sNom As String
Dim sFinal As String
sDossier = ThisWorkbook.Path
sNom = "Demande d'inscription et de réinscription"
sNom = sNom & " " & Format(Now, "dd mmm yy hhmmss")
sFinal = sDossier & "\" & sNom
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=sFinal, _
Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
Sub MacroSauv_03()
Dim sDossier As String, sNomFichier As String
Dim sNom As String, sPrenom As String, sDate As String
Dim sFinal As String
sDossier = ThisWorkbook.Path
sNomFichier = "Demande d'inscription et de réinscription"
sNom = sFormulaire.Range("C9")
sPrenom = sFormulaire.Range("H9")
sDate = sFormulaire.Range("D10")
sNomFichier = sNomFichier & " " & sNom & " " & sPrenom & " " & Replace(sDate, "/", "_") & ".pdf"
sFinal = RenommerFichier(sDossier, sNomFichier)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=sFinal, _
Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End Sub
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