Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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

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é
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
 
Vote positif 0 Vote négatif

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

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

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

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

XLDnaute Barbatruc
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
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

N
  • Question
XL 2013 Fixer la valeur d'une cellule saisie en fonction d'un nombre de décimal défini
Réponses
6
Affichages
262
mapomme
P
  • Résolu(e)
XL 2019 Macro protection s'active si username absent de la liste
Réponses
11
Affichages
477
pat66
P
V
  • Résolu(e)
XL 2019 fonction SI
Réponses
4
Affichages
167
nat54
M
  • Question
XL 2021 Colorer avec condition de temps
2
Réponses
27
Affichages
717
matlatarte
M
D
  • Question
XL 2021 Fusion de cellule si vide à côté
Réponses
11
Affichages
258
job75
Z
  • Résolu(e)
XL 2021 Tester l'existence d'un nom d'onglet
Réponses
3
Affichages
251
jm.andryszak
J
L
  • Question
Microsoft 365 recherche X lien entre 2 fichiers
Réponses
3
Affichages
182
lilie17
L
R
  • Question
Microsoft 365 Formule INDIRECT avec nom du classeur variable
Réponses
4
Affichages
676
job75
XLS : Modèle pour ouvrir un classeur sur une nouvelle Session Excel
Réponses
0
Affichages
207
Lu76Fer
C
  • Résolu(e)
Copier/Masquer des lignes de couleur pour alimenter un tableau
Réponses
9
Affichages
530
vgendron
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…