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
sNomfichier = Feuil1.Range("M4")
sExt1 = ".xlsm"
sExt2 = ".pdf"
If NomFichierValide(sNomfichier) = False Then
Feuil1.Range("M4").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)
ActiveWorkbook.SaveAs Filename:=sFichierFinal, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled
sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
Feuil2.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=sFichierFinal, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
ActiveWorkbook.Close True
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