Option Explicit
Sub SupprimeTout()
'Enregistre le classeur et supprime la totalité des procédures
'Nécessite d'activer la référence Microsoft Visual Basic for Applications Extensibility 5.3
Dim VbComp As VBComponent, s As String
If MsgBox(prompt:="Cette procédure va fermer ce classeur et en afficher une copie de laquelle TOUTES LES MACROS SERONT EFFACEES." _
, Buttons:=vbOKCancel, Title:="Attention !") = 2 Then End
'Enregistre le classeur
s = InputBox(prompt:="Inscrivez le nom que vous voulez donner à la copie de " & ThisWorkbook.Name, _
Title:="Suite de la procédure", Default:="Copie de " & ThisWorkbook.Name)
If s = "" Then End
If Right$(s, 4) <> ".xls" Then s = s & ".xls"
s = ThisWorkbook.Path & "\" & s
If s = ThisWorkbook.FullName Then
If MsgBox(prompt:="Vous vous apprêtez à remplacer le classeur original par un classeur SANS MACRO." _
, Buttons:=vbOKCancel, Title:="Attention !") = 2 Then End
End If
Application.DisplayAlerts = False: ThisWorkbook.SaveAs s: Application.DisplayAlerts = True
For Each VbComp In ThisWorkbook.VBProject.VBComponents
Select Case VbComp.Type
Case 1 To 3: ThisWorkbook.VBProject.VBComponents.Remove VbComp
Case Else: With VbComp.CodeModule: .DeleteLines 1, .CountOfLines: End With
End Select
Next VbComp
End Sub