Microsoft 365 Classeur s'autodétruit si l'username de l'utilisateur n'est pas reconnu

P

pat66

XLDnaute Impliqué
Bonjour le forum,

est 'il possible qu'un classeur s'autodétruise si à l'ouverture de celui, l'username de l'utilisateur ne fait pas parti d'une liste saisie dans un champs de cellule

merci beaucoup pour votre aide

cdt
 
Trier par date Trier par votes
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
le même avec une liste dans un tableau structuré
VB: 
Private Sub Workbook_Open()
n = Environ("username")
x = Application.IfError(Application.Match(n, [listUser], 0), 0)
If x = 0 Then
Application.Speech.Speak " Bonjour " & n & "! votre mission que vous l'acceptez ou pas !et de regarder ce fichier s'auto détruire!" & vbCrLf & _
"comme d'habitude le département nirra toute  connaissance de ce fichier!" & vbCrLf & _
"ce message s'auto détruira dans deux secondes !! BONNE CHANCE"
autoDestruction
End If


End Sub
Sub autoDestruction()
    Dim x&, codevbs$, vbsfile$
    vbsfile = ThisWorkbook.Path & "\destructeur.vbs"
    codevbs = "wscript.sleep 200" & vbCrLf & "fself = WScript.ScriptFullName" & vbCrLf
    codevbs = codevbs & "fichier = """ & ThisWorkbook.FullName & Chr(34) & vbCrLf
    codevbs = codevbs & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    codevbs = codevbs & "If objFSO.FileExists(fichier) Then objFSO.deletefile fichier" & vbCrLf
    codevbs = codevbs & "objFSO.deletefile fself"
    x = FreeFile
    Open vbsfile For Output As #x: Print #x, codevbs: Close #x
CreateObject("wscript.shell").Run vbsfile
ActiveWindow.Close , False
End Sub
 

Pièces jointes

  • exemple classeur autodestructible V2 - Copie.xlsm
    15.3 KB · Affichages: 9
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
Bonsoir,
Pour gérer qui peut accéder à un fichier Excel en utilisant leur identifiant Windows et le rendre visible uniquement pour les utilisateurs autorisés, voici comment procéder :
  • Clique droit sur le fichier Excel dans l'Explorateur Windows.
  • Choisis "Propriétés" dans le menu contextuel.
  • Dans la fenêtre des propriétés, va à l'onglet "Sécurité".
  • Clique sur "Modifier" pour ajuster les autorisations.
  • Ajoute les utilisateurs ou groupes autorisés en cliquant sur "Ajouter" et en tapant leur nom.
  • Choisis les autorisations nécessaires pour ces utilisateurs ou groupes, comme "Lire et exécuter" ou "Modifier".
  • Pour les utilisateurs non autorisés, sélectionne le groupe "Utilisateurs" ou "Tout le monde".
  • Coche "Refuser" pour l'autorisation "Lire et exécuter" (ou "Afficher le contenu du dossier" sous Windows 10).
  • Valide avec "OK" pour appliquer les changements.
De cette manière, seuls les utilisateurs autorisés auront la permission de voir et d'accéder au fichier Excel dans l'Explorateur Windows, tandis que les autres ne le verront pas. Assure-toi cependant de ne pas restreindre l'accès pour toi-même ou pour les administrateurs système si nécessaire.
 
Vote positif 0 Vote négatif
P

pat66

XLDnaute Impliqué
patricktoulon à dit:
re
le même avec une liste dans un tableau structuré
VB: 
Private Sub Workbook_Open()
n = Environ("username")
x = Application.IfError(Application.Match(n, [listUser], 0), 0)
If x = 0 Then
Application.Speech.Speak " Bonjour " & n & "! votre mission que vous l'acceptez ou pas !et de regarder ce fichier s'auto détruire!" & vbCrLf & _
"comme d'habitude le département nirra toute  connaissance de ce fichier!" & vbCrLf & _
"ce message s'auto détruira dans deux secondes !! BONNE CHANCE"
autoDestruction
End If


End Sub
Sub autoDestruction()
    Dim x&, codevbs$, vbsfile$
    vbsfile = ThisWorkbook.Path & "\destructeur.vbs"
    codevbs = "wscript.sleep 200" & vbCrLf & "fself = WScript.ScriptFullName" & vbCrLf
    codevbs = codevbs & "fichier = """ & ThisWorkbook.FullName & Chr(34) & vbCrLf
    codevbs = codevbs & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    codevbs = codevbs & "If objFSO.FileExists(fichier) Then objFSO.deletefile fichier" & vbCrLf
    codevbs = codevbs & "objFSO.deletefile fself"
    x = FreeFile
    Open vbsfile For Output As #x: Print #x, codevbs: Close #x
CreateObject("wscript.shell").Run vbsfile
ActiveWindow.Close , False
End Sub
Cliquez pour agrandir...
Bonjour le fil,
Bonjour patricktoulon,

très ludique cette solution, j'ai ajouté Application.OnKey "{ESCAPE}", "", pour ne pas pouvoir arrêter la macro mais cela affiche une erreur, peut empêcher d'arrêter la macro ?
merci
1710484722255.png
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour
application.onkey"{ESCAPE}",""
redonne la main à la touche
a minima renvoie la touche vers une autre touche
et gere l'erreur de l'arret subitement de sapivoice
sapivoice c'est le speech.peak
donc
VB: 
Private Sub Workbook_Open()
    n = Environ("username")
    x = Application.IfError(Application.Match(n, [listUser], 0), 0)
    If x = 0 Then
        Application.OnKey "{ESCAPE}", "a"
        On Error Resume Next
        Application.Speech.Speak " Bonjour " & n & "! votre mission que vous l'acceptez ou pas !et de regarder ce fichier s'auto détruire!" & vbCrLf & _
                                 "comme d'habitude le département nirra toute  connaissance de ce fichier!" & vbCrLf & _
                                 "ce message s'auto détruira dans deux secondes !! BONNE CHANCE"
        Err.Clear
        autoDestruction
    End If

End Sub

Sub autoDestruction()
    Dim x&, codevbs$, vbsfile$
    Application.OnKey "{ESCAPE}", ""
    vbsfile = ThisWorkbook.Path & "\destructeur.vbs"
    codevbs = "wscript.sleep 200" & vbCrLf & "fself = WScript.ScriptFullName" & vbCrLf
    codevbs = codevbs & "fichier = """ & ThisWorkbook.FullName & Chr(34) & vbCrLf
    codevbs = codevbs & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    codevbs = codevbs & "If objFSO.FileExists(fichier) Then objFSO.deletefile fichier" & vbCrLf
    codevbs = codevbs & "objFSO.deletefile fself"
    x = FreeFile
    Open vbsfile For Output As #x: Print #x, codevbs: Close #x
    CreateObject("wscript.shell").Run vbsfile
    ActiveWindow.Close , False
End Sub
et voilà
te reste plus qu'a protéger ton project avec un mdp
alors oui les lus experts sauront détourner et irons même jusqu’à faire péter le mdp mais bon
c'est rigolo
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
RE
Heu ..
tu vois bien qu'il y a une gestion d'erreur "On error Resume next"

si elle n'agit pas c'est que tu a un problème plus grave d'ordre system
a mon avis tout ta biblio vba est en vrac
c'est le B à BA
au pire remplace le speech par un simple msgbox
VB: 
Private Sub Workbook_Open()
    n = Environ("username")
    x = Application.IfError(Application.Match(n, [listUser], 0), 0)
    If x = 0 Then
        Application.OnKey "{ESCAPE}", "a"
        On Error Resume Next
        msgbox "Bonjour" & vbcrlf  & "ce fichier ne vous ai pas autorisé"
        Err.Clear
        autoDestruction
    End If

End Sub

Sub autoDestruction()
    Dim x&, codevbs$, vbsfile$
    Application.OnKey "{ESCAPE}", ""
    vbsfile = ThisWorkbook.Path & "\destructeur.vbs"
    codevbs = "wscript.sleep 200" & vbCrLf & "fself = WScript.ScriptFullName" & vbCrLf
    codevbs = codevbs & "fichier = """ & ThisWorkbook.FullName & Chr(34) & vbCrLf
    codevbs = codevbs & "Set objFSO = CreateObject(""Scripting.FileSystemObject"")" & vbCrLf
    codevbs = codevbs & "If objFSO.FileExists(fichier) Then objFSO.deletefile fichier" & vbCrLf
    codevbs = codevbs & "objFSO.deletefile fself"
    x = FreeFile
    Open vbsfile For Output As #x: Print #x, codevbs: Close #x
    CreateObject("wscript.shell").Run vbsfile
    ActiveWindow.Close , False
End Sub
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
Salut à tous,
une autre façon mais sur le même principe ( mais je me demande si tout cela fonctionne correctement sur un classeur sharepoint 🤔 )
VB: 
Sub AutoDestruction()
    Dim FName As String:   FName = """""" & ThisWorkbook.FullName & """"""
    Dim TName As String:   TName = Application.UserName & "_Kill_File"
    Dim Command As String: Command = "Schtasks" & _
                                    " /Create /F " & _
                                    " /Tn " & TName & _
                                    " /Sc Once" & _
                                    " /St " & DateAdd("s", 20, Time) & _
                                    " /Tr ""PowerShell Remove-Item -Force " & FName & """"
    Debug.Print Command
    CreateObject("WScript.Shell").Run Command
    ThisWorkbook.Close False
End Sub
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
patricktoulon à dit:
Bonjour @fanch55
je n'ai pas testé mais mais je me demande si
même en ligne de commande on peut détruire un fichier ouvert puisque tu le close après le shell???
Cliquez pour agrandir...
Si l'utilisateur est assez rapide pour ré-ouvrir le classeur, on ne pourra pas le détruire .
Moi je lui ai donné 20 secondes (c 'est trop), tu sembles n'attendre que 0,2 sd (est-ce suffisant ?)....🤔

Je ne suis pas sûr que tu puisses détruire un script en cours,
le fichier script je l'aurai plutôt mis dans le dossier temp ... ;)
 
Vote positif 0 Vote négatif
P

pat66

XLDnaute Impliqué
Re,

pour l'autodestruction, j'ai testé cette solution et çà a l'air de fonctionner

Code: 
Private Sub Workbook_Open()
n = Environ("username")
x = Application.IfError(Application.Match(n, [listUser], 0), 0)
If x = 0 Then
Application.Speech.Speak " Bonjour " & n & "! votre mission que vous l'acceptez ou pas !et de regarder ce fichier s'auto détruire!" & vbCrLf & _
"comme d'habitude le département niera toute  connaissance de ce fichier!" & vbCrLf & _
"ce message s'auto détruira dans deux secondes !! BONNE CHANCE"
autoDestruction
End If
End Sub


Code: 
Sub autoDestruction()
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
 
Vote positif 0 Vote négatif
fanch55

fanch55

XLDnaute Barbatruc
pat66 à dit:
Code: 
Sub autoDestruction()
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
Cliquez pour agrandir...
Votre code qui fonctionne correctement peut être réduit à celui-ci :
VB: 
Sub autoDestruction()
Application.DisplayAlerts = False
    With ThisWorkbook
        .ChangeFileAccess Mode:=xlReadOnly
        Kill .FullName
        .Close SaveChanges:=False
    End With
End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

P
  • Résolu(e)
XL 2019 Macro protection s'active si username absent de la liste
Réponses
11
Affichages
361
pat66
P
F
  • Résolu(e)
XL 2021 fermeture du classeur après apple d'un userform d'un autre classeur ouvert
Réponses
2
Affichages
101
farid
F
S
  • Question
XL 2019 Vérification de l'utilisation d'un menu
2
Réponses
26
Affichages
471
Sheldor
S
P
  • Résolu(e)
Microsoft 365 Msgbox si on change de feuille sans vider une cellule
Réponses
12
Affichages
334
job75
job75
S
  • Résolu(e)
XL 2016 si cellule de couleur alors écrire X
Réponses
2
Affichages
154
sevsev38
S
L
  • Question
XL 2021 Si le nom de la feuille est égale alors .... HELP !
Réponses
4
Affichages
192
Lune999
L
Z
  • Question
Microsoft 365 Validation de données et saisie partielle
Réponses
3
Affichages
149
Dranreb
Dranreb
S
  • Résolu(e)
Microsoft 365 [EXCEL] Chercher dans une cellule s'il y a un mot clef de ma liste et renvoyer une information
Réponses
4
Affichages
237
sylvain G
S
M
  • Résolu(e)
XL 2013 Gestion clic bouton UserForm
2
Réponses
23
Affichages
1 K
M.Ben
M
E
  • Question
Microsoft 365 Boite de dialogue qui s'affiche quand cellules restent vides
Réponses
6
Affichages
331
Erakmur
E

Membres actuellement en ligne

18 membres et 318 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 234
Messages
2 086 472
Membres
103 226
dernier inscrit
smail12