Adapter code pour restreindre l'ouverture d'un fichier

Bonsoir

Je souhaite de l'aide pour adapter le code ci-dessous à mon besoin.

En effet, je souhaite restreindre les utilisateurs en fonction de leur username.

Je souhaite aussi définir des dates d'expirations pour les utilisateurs autorisés.

Merci

Application.ScreenUpdating = False 'l'utilisateur ne voit pas les changement sur son écran

'la date d'expiration

DateExpiration = DateSerial(2019, 12, 31) ' <= choisissez la date d'expiration >>> via la fonction DateSerial avec les paramètres (aaaa, mm, jj)

'compare la date d'expiration avec la date d'aujourd'hui

'If DateExpiration <= Date Then

'If UserName <> "gogo" Or UserName <> "baba" Or UserName <> "shef" Or UserName <> "ordi" Or UserName <> "yamba" Or UserName <> "labo" Then

'autodestruction de fichier Excel (le fichier s'efface lui-même)

    Dim NomComplet As String

    NomComplet = Application.ActiveWorkbook.FullName

    ActiveWorkbook.Saved = True

    Application.ActiveWorkbook.ChangeFileAccess xlReadOnly

    Kill NomComplet

    Application.ActiveWorkbook.Close False

Else

End If

Application.ScreenUpdating = True 'on réenclanche l'affichage des changements

Bonjour,

Code à mettre dans le module du classeur (ThisWorkbook) du fichier que tu va distribuer. Il te faut adapter les noms des différents utilisateurs. A l'ouverture du classeur, un test est fait sur le nom d'utilisateur puis sur la date limite :

Private Sub Workbook_Open()

    Dim Utilisateur As String
    Dim DateExpiration As Date
    Dim Message As String

    Utilisateur = Environ("USERNAME")

    Message = Utilisateur & "," & _
              vbCrLf & _
              "Votre date limite d'utilisation de ce fichier est arrivée " & _
              "à expiration vous n'avez plus l'autorisation de l'utiliser !" & _
              vbCrLf & _
              vbCrLf & _
              "Contactez le propriétaire du fichier pour qu'il vous le comunique " & _
              "à nouveau car celui-ci va être détruit !"

    Select Case Utilisateur

        Case "Pierre"
            DateExpiration = DateSerial(2018, 5, 31)
            If DateExpiration <= Date Then Detruire Utilisateur, Message

        Case "Yves", "Thierry", "Lucien"
            DateExpiration = DateSerial(2019, 12, 31)
            If DateExpiration <= Date Then Detruire Utilisateur, Message

        Case "Alain"
            DateExpiration = DateSerial(2019, 7, 31)
            If DateExpiration <= Date Then Detruire Utilisateur, Message

        Case Else
            Message = "Attention !" & _
                      vbCrLf & _
                      "Vous n'avez pas le droit d'utiliser ce fichier." & _
                      vbCrLf & _
                      vbCrLf & _
                      "Si vous souhaitez utiliser ce fichier, contactez le propriétaire pour qu'il vous le comunique " & _
                      "de façon officielle car celui-ci va être détruit !"

            Detruire "", Message

    End Select

End Sub

'autodestruction de fichier Excel (le fichier s'efface lui-même)
Sub Detruire(Utilisateur As String, Message As String)

    Dim NomComplet As String

    MsgBox Message, vbCritical, "Expiration."

    Application.ScreenUpdating = False 'on réenclanche l'affichage des changements

    NomComplet = Application.ActiveWorkbook.FullName

    ThisWorkbook.Saved = True

    ThisWorkbook.ChangeFileAccess xlReadOnly

    Kill NomComplet

    ThisWorkbook.Close False

    Application.ScreenUpdating = True 'on réenclanche l'affichage des changements

End Sub

Bonjour These

Je m'excuse du temps mis pour vous revenir.

Merci pour votre solution.

Les tests ne sont pas concluants.

J'ai bien respecté le nom des utilisateurs mais quant ils ouvrent le fichier sur leur poste, le fichier se ferme même chez mois également.

Merci de revoir les cases svp

Bonjour,

ben ouvre-le en refusant les macros avec Shift 'Ouvrir'

eric

Bonjour,

Je viens de faire une série de tests et le fichier fonctionne très bien chez moi.

Exécutes le code en pas à pas et regardes que les noms d'utilisateurs correspondent en tout point (à la lettre et à l'accent près) avec les noms entrés en dur, attention si tu n'as pas mis "Option Compare Text" en tête de module, la casse est importante, "pierre" est différent de "Pierre". Quand tu fais les tests, met en commentaire les lignes de code de la sub "Detruire()" en ne laissant que la ligne [MsgBox Message, vbCritical, "Expiration."] active et tu peux faire un test de correspondance après avoir récupéré le nom de l'utilisateur :

Utilisateur = Environ("USERNAME")
MsgBox Utilisateur = "Pierre"

Vrai ou Faux te seras retourné selon le cas

Bonjour Theze

En parcourant mes messages, je me suis rendu compte que je n'avais plus donné de suite.

Juste vous dire merci car j'avais mal adapté le code dans mon cas réel.

Je fonctionne bien.

Encore merci et toutes mes excuses pour le retard;

Bonjour,

Pas grave, l'important c'est que tu ais pus te dépanner