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

pat66 · 14 Mars 2024

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

Valtrase · 14 Mars 2024

Bonjour à tous,

ce problème est apparu dès que j'ai voulus déplacer le champs "habilitation" sur une autre feuille, bizarre !!

Pour ma part je vérifierais dans le gestionnaire de noms si tout est OK

patricktoulon · 14 Mars 2024

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

dysorthographie · 14 Mars 2024

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.

pat66 · 15 Mars 2024

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

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

patricktoulon · 15 Mars 2024

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

pat66 · 15 Mars 2024

re,
désolé mais toujours la même erreur enappuyant sur ESCAPE

patricktoulon · 15 Mars 2024

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

pat66 · 15 Mars 2024

re,

ok, un grand merci quand même, je vais tester tout çà !

cdt

fanch55 · 15 Mars 2024

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

patricktoulon · 15 Mars 2024

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???

fanch55 · 15 Mars 2024

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???

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 ...

pat66 · 15 Mars 2024

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

fanch55 · 15 Mars 2024

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

J'ai testé la version de @patricktoulon et la votre ,
Tout fonctionne .
@patricktoulon : je suis bluffé qu'un script puisse détruire son contenant ....

fanch55 · 15 Mars 2024

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

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

patricktoulon · 15 Mars 2024

fanch55 à dit:
J'ai testé la version de @patricktoulon et la votre ,
Tout fonctionne .
@patricktoulon : je suis bluffé qu'un script puisse détruire son contenant ....

re
le vbs c'est comme le cmd
c'est une instance du vbs il n'a donc rien a voir avec le fichier vbs lui même
cmd c'est pareil

Effectuez une recherche sur Excel Downloads...

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

pat66

XLDnaute Impliqué

Valtrase

XLDnaute Occasionnel

patricktoulon

XLDnaute Barbatruc

Pièces jointes

dysorthographie

XLDnaute Accro

pat66

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

pat66

XLDnaute Impliqué

patricktoulon

XLDnaute Barbatruc

pat66

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

pat66

XLDnaute Impliqué

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums