Auto-destruction d'un classeur ouvert

Soyez le premier à donner votre avis sur cette source.

Snippet vu 6 567 fois - Téléchargée 22 fois

Commenter

Contenu du snippet

Le code de Chip Pearson et Bob Umlas est bien connu pour une telle opération (je l'ai rappelé)
Toutefois, le classeur peut contenir des VALEURS que l'on veut ne PAS détruire
Ctte appli (sans prétention!) permet donc de conserver les valeurs existantes dans le classeur, mais détruit TOUT le reste :
Macros, bien sûr, mais aussi les formats, formules, etc...
Cette destruction partielle pourra être déclenchée par l'évènement de votre choix (une date limite par exemple), et SANS avertissement: Il convient en effet de ne pas faire état de cette "protection" supposée inconnue et "cachée" dans un ensemble de macros (les noms retenus pour les sub sont ici explicites : il conviendra de les changer par d'autres plus anodins).
Cela pourra compléter efficacement d'autres méthodes commme par exemple celle de bigfish_le vrai sur le forum : http://www.vbfrance.com/codes/ASTUCE-AMELIORER-SECURITE-ACCES-DONNEES-CODE-FICHIER-EXCEL_48448.aspx

Source / Exemple : 


'Dans le module "Suicider" :

Sub SuiciderSansTrace()
'Méthode 1
'Auto-détruire le Classeur et sa trace dans Documents Récents
'Références : Chip Pearson et Bob Umlas

    Dim Hist As Integer
    
    With ThisWorkbook
        .Save
        For Hist = 1 To Application.RecentFiles.Count
            If Application.RecentFiles(Hist).Path = .FullName Then
                Application.RecentFiles(Hist).Delete
                Exit For
            End If
        Next Hist
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close SaveChanges:=False
        Application.Quit
    End With
    
End Sub

'------------------------------------------------------

Sub SuiciderSansTraceSaufValeurs()
'Méthode 2
'Ne conserve QUE LES VALEURS du Classeur à détruire et tue tout le reste

    Dim ShNb As Integer, Sht As Integer, Hist As Integer
    
    Dim WbFn As String, Wbn As String, TmpWbn As String, Shn As String
    
    'Reprendre le chemin et nom du Classeur à détruire
    WbFn = ThisWorkbook.FullName
    
    'Reprendre le nom du Classeur à détruire
    Wbn = ThisWorkbook.Name

    'Créer un Classeur temporaire TmpWbn pour accueillir les données du Classeur à détruire
    'Valeur initiale du Nombre de feuilles crées par l'application
    ShNb = Application.SheetsInNewWorkbook
    'Création du même nombre de feuilles que Classeur à détruire
    Application.SheetsInNewWorkbook = Workbooks(Wbn).Sheets.Count
    Set Newbook = Workbooks.Add
    TmpWbn = ActiveWorkbook.Name
    'Remise à la Valeur initiale dans l'application
    Application.SheetsInNewWorkbook = ShNb
    
    'Copier chaque feuille du Classeur à détruire dans le Classeur temporaire TmpWbn
    For Sht = 1 To Workbooks(Wbn).Sheets.Count
        Shn = Workbooks(Wbn).Sheets(Sht).Name
        Workbooks(Wbn).Sheets(Sht).Cells.Copy
        Workbooks(TmpWbn).Sheets(Sht).Cells.PasteSpecial _
            Paste:=xlPasteValues, _
            Operation:=xlNone, _
            SkipBlanks:=False, _
            Transpose:=False
        Workbooks(TmpWbn).Sheets(Sht).Name = Shn
        Workbooks(TmpWbn).Sheets(Sht).Activate
        Range("A1").Select
    Next Sht
    Application.CutCopyMode = False

    'Renommer le Classeur à détruire puis le supprimer
    Workbooks(Wbn).SaveAs Filename:="C:\Killed"
    Kill WbFn

    'Renommer le Classeur temporaire TmpWbn comme le Classeur détruit, l'enregistrer et le fermer (même chemin)
    Workbooks(TmpWbn).SaveAs Filename:=WbFn
    Workbooks(Wbn).Close SaveChanges:=True

    'Détruire le Classeur (Références : Chip Pearson et Bob Umlas)
    With ThisWorkbook
        .Save
        'Accessoirement : Supprimer l'historique du Classeur détruit
        '------------------------------------------------------------
        'For Hist = 1 To Application.RecentFiles.Count              '
        '    If Application.RecentFiles(Hist).Path = .FullName Then '
        '        Application.RecentFiles(Hist).Delete               '
        '        Exit For                                           '
        '    End If                                                 '
        'Next Hist                                                  '
        '------------------------------------------------------------
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
    End With
    
    'Quitter
    If Workbooks.Count < 2 Then
        ThisWorkbook.Saved = True
        Application.Quit
    Else
        ThisWorkbook.Close SaveChanges:=False
    End If
    
End Sub

'-------------------------------------------------

'Dans "ThisWorkbook" :

Private Sub Workbook_Open()

'ATTENTION :
    'Si vous décommentez ici, vous perdrez tout !
    'Faites d'abord une sauvegarde !

    'Exemple d'Auto-destruction du Classeur avec une Date au 1er Janvier 2013
    'If Date > DateSerial(2013, 1, 1) Then
        'Décommenter le mode choisi
        'SuiciderSansTrace
        'SuiciderSansTraceSaufValeurs
    'Else
        'Ouverture du Classeur autorisée
        'Call ...
        'MsgBox "..."
    'End If

End Sub

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (CerberusPau)