Interdire d'enregistrer sous un nom de fichier

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim rèpDialogue As Variant         'Réponse de la boite de dialogue Excel
Dim nomFichier As String           'Nom du fichier original
Dim nomProposé As String           'Nom de fichier proposé ou saisi 
Dim txt As String                  'Titre de la boite de message
Dim msg As String                  'Message pour boite de message
Dim rép As Integer                 'Réponse à une boite de message

Application.EnableEvents = False
'Proposer l'enregistrement (nomfichier-1.xlsm)
nomFichier = ThisWorkbook.Name
nomProposé = Mid(nomFichier, 1, InStrRev(nomFichier, ".") - 1) & _
             "-1" & _
             Mid(nomFichier, InStrRev(nomFichier, "."))
txt = "Enregistrer le fichier avec autre nom"
Do
  rèpDialogue = Application.GetSaveAsFilename(InitialFileName:=nomProposé, _
                  FileFilter:="Classeur Excel (*.xlsm) , *.xlsm", Title:=txt)
  If rèpDialogue = False Then
    Application.EnableEvents = True
    Cancel = True
    Exit Sub
  End If
  nomProposé = StrReverse(rèpDialogue)
  nomProposé = StrReverse(Mid(nomProposé, 1, InStr(1, nomProposé & "\", "\") - 1))
  If nomProposé = nomFichier Then
    msg = "Vous ne pouvez pas enregistret le fichier avec " & vbCr & _
          "le même nom, que l'original (" & nomFichier & ")" & vbCr & vbCr & _
          "Saisir un autre nom."
    rép = MsgBox(msg, vbExclamation + vbOKCancel, txt)
  End If
Loop While nomProposé = nomFichier
On Error GoTo ErrorHandler
ActiveWorkbook.SaveAs Filename:=nomProposé
On Error GoTo 0
Application.EnableEvents = True
Cancel = True
Exit Sub

ErrorHandler:          'Routine de gestion d'erreur.
'------------
'Évalue le numéro d'erreur.
Select Case Err.Number
  Case 1004
    'Le fichier existe déjà ou l'enregistrement à été annulé
    If Err.Description = "La méthode 'SaveAs' de l'objet '_Workbook' a échoué" Then
      Resume Next
    Else
      'Le fichier est déjà ouvert
      MsgBox "L'enregistrement à échoué :" & vbCr & vbCr & Err.Description, vbInformation, txt
      Resume Next
    End If
  Case Else
    MsgBox Err.Description, vbCritical, txt
    Resume Next
End Select
End Sub