XL 2013 Fichier Excel qui s'autodetruit

julien91080

XLDnaute Occasionnel
Bonjour a la communauté,

Je souhaite avoir un code qui au moment de l'ouverture d'un fichier excel, le code vérifie l'emplacement de ce dernier et s'il n'est pas dans un répertoire précis, alors il se détruit/supprime.

Je suis embêté car j'ai trouvé un code qui fonctionne sur du .xls mais pas du .xlsm:

Dans Thisworkbook:
Private Sub Workbook_Open()
If ThisWorkbook.Path <> "C:\Users\transfert" Then
Call Suicide2
End If
End Sub

Dans un module :

Option Explicit

Sub Suicide2()
With ThisWorkbook
.Save
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
End Sub

Ca fonctionne affreusement bien sur du 2003 mais il n'apprécie pas le " Kill .FullName". Mais je voudrais que cela fonctionne sur du Excel 2010 .

Merci par avance pour votre aide.

Cordialement
 

job75

XLDnaute Barbatruc
Bonsoir,

Je ne comprends pas, le code du post #1 fonctionne sur les fichiers .xlsm, en tout cas chez moi sur Excel 2013.

Mais ce code dans Thisworkbook est bien plus simple et plus complet :
Code:
Private Sub Workbook_Open()
If Me.Path <> "C:\Users\transfert" Then
  Me.ChangeFileAccess xlReadOnly
  Kill Me.FullName
  Me.Saved = True
  If Workbooks.Count = 1 Then Application.Quit Else Me.Close
End If
End Sub
Bonne nuit.
 

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous,

Il y a quelques temps, j'ai beaucoup cherché ce genre de code.
Je ne sais plus où je l'ai obtenu mais j'ai ce code qui autodétruit le fichier ouvert à la date de votre choix, quel que soit son nom, sa version et son emplacement.

Dans le Thisworkbook
Code:
Private Sub Workbook_Open()
If CLng(Date) > 43000 Then '43000 =nbr 22/09/2017 autodestruction
    MsgBox ("Cliquez pour continuer")
    Call Suicide2
End If
end sub

dans un module
Code:
Sub Suicide2()
    With ThisWorkbook
        .Save
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close SaveChanges:=False
    End With
End Sub

On peut simplifier comme ceci :
Uniquement dans le Thisworkbook
Code:
Private Sub Workbook_Open()
If CLng(Date) > 43000 Then '43000 =nbr 22/09/2017 autodestruction
    MsgBox ("Cliquez pour continuer")
    With ThisWorkbook
        .Save
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close SaveChanges:=False
        End With
End If
End Sub

ça fonctionne super bien
Bonne journée à toutes et à tous,
Amicalement,
Lionel,
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Bonjour le fil, le forum, job75 ;), arthour973

[aparté du petit matin, la clope au bec]
Pourquoi créer un classeur pour le détruire ensuite?
C'est de la maltraitance caractérisée envers les Cellules Sacrées du Grand Tableur ;)

Sinon il suffit d'ouvrir le classeur sans activer les macros pour enrayer la destruction du dit classeur
(mais cela tu le sais déjà arthour973, on a eu l'occasion d'en débattre au fil d'une de tes discussions sur XLD)
[/aparté du petit matin, la clope au bec]
 

Bulr6

XLDnaute Nouveau
Donc en fait tu ne voudrais laisser la possibilité que de sauvegarder le fichier à son emplacement et avec un nom particulier ? ça je en sais pas si c'est possible et j'allais te proposer la même solution le module "suicide"

dans thisworkbook :
VB:
Private Sub Workbook_Open()
If Date > DateSerial(2017, 12, 1) Then
Suicide
Else
MsgBox "Have a nice day  !"
End If
End Sub

et dans un module :
VB:
Sub Suicide()
Dim FName As String
Dim Ndx As Integer
With ThisWorkbook
.Save
For Ndx = 1 To Application.RecentFiles.Count
If Application.RecentFiles(Ndx).Path = .Name Then
Application.RecentFiles(Ndx).Delete
Exit For
End If
Next Ndx
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
End Sub
 

julien91080

XLDnaute Occasionnel
Bonjour Messieurs,

Je penses comprendre le soucis: tous vos codes fonctionnent mais je test sur "Mon bureau" de mon entreprise.
Or, nous avons OneDrive de déployé. Je pense que OneDrive bloque la suppression et que du fait, je ne pourrais jamais le supprimer n'ayant pas les "droits".

Merci pour votre aide.
 

Discussions similaires

Réponses
14
Affichages
356
Compte Supprimé 979
C
Réponses
2
Affichages
99