Blocage enregistrement fichier

Bonsoir

Ce code, via un bouton, enregistre imprime et efface les données saisies dans chaque feuille

Des petits malins pour aller plus vite utilise la fonction d'enregistrement de Excel ce qui fait que des données subsistent toujours dans le fichier

Selon vous, qu'est ce que je pourrais rajouter à ce code afin d'empêcher tout enregistrement autre qu'en cliquant sur le bouton

Ce bouton existe sur chaque feuille

Voici le code

Sub SaveFeuilleActive()
Dim Sh As Shape
     ActiveSheet.Unprotect "rupture2012"
     ActiveSheet.Copy
     'Affiche la boîte de dialogue
     Application.Dialogs(xlDialogSaveAs).Show
     ActiveSheet.PrintOut
     On Error Resume Next
     For Each Sh In ActiveSheet.Shapes
     If Sh.Name Like "Button*" Then Sh.Delete
    Next Sh
    On Error GoTo 0
     ActiveSheet.Protect Password:="rupture2012"
     ActiveWorkbook.Save
     ActiveWorkbook.Close
     Select Case ActiveSheet.Name
     Case "ICL Cadres Métallurgie"
         Range("B1:B4,B6,B9,B10,B13,E3:E14,B40,B42").ClearContents
         MsgBox "les données sont effacées"
     Case "ICL Etam Ouvriers Métallurgie"
         Range("B1:B6,B9,B10,B13,E3:E14,B35,B37").ClearContents
         MsgBox "les données sont effacées"
     Case "ICL Ouvriers TP", "ICL Ouvriers Bâtiment"
         Range("B1:B4,B6,B9,B10,B13,E3:E15,B36,B38").ClearContents
         MsgBox "les données sont effacées"
     Case "ICL Cadres Intermittents", "ICL Non Cadres Intermittents"
         Range("B1:B4,B6,B9,B10,B14,E3:E14,B31,B33").ClearContents
         MsgBox "les données sont effacées"
     Case "ICL IAC Bâtiment", "ICL Etam Bâtiment", "ICL IAC TP", "ICL ETAM TP"
         Range("B1:B4,B6,B9,B10,B13,F3:F15,E14,B38,B40").ClearContents
         MsgBox "les données sont effacées"
     Case "Ind Retraite IAC TP", "Ind Retraite IAC Bâtiment", "Ind Retraite ETAM TP", "Ind Retraite ETAM Bâtiment"
         Range("B1:B4,B6,B9,B10,F3:F14,E14").ClearContents
         MsgBox "les données sont effacées"
     Case "Ind Retraite Métallurgie", "Ind Retraite Intermittents"
         Range("B1:B6,B9,B10,F3:F14").ClearContents
         MsgBox "les données sont effacées"
      Case "Ind Retraite SYNTEC"
         Range("B1:B6,B9,B10,E14,F3:F14").ClearContents
         MsgBox "les données sont effacées"
     Case "ICL CADRES SYNTEC"
         Range("B1:B4,B6,B9,B10,B14,B31,B33,E3:E14").ClearContents
         MsgBox "les données sont effacées"
     Case "ICL ETAM SYNTEC"

Merci par avance

Cdt

Bonjour

Code à placer dans le module ThisWorkbook

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim Passe As String
  Passe = InputBox("Mot de passe")
  If Passe <> "tutu" Then
    MsgBox "Enregistrement interdit : Utiliser le bouton prévu à cet effet"
    Cancel = True
  End If
End Sub

Bonsoir

Nickel

Merci pour tout

Cdt