[VBA] Test autorisations sur dossier

Bonjour le forum

Je suis en train de me créer une fonction personnalisée pour tester l'existance ou non d'un dossier, puis de vérifier si l'utilisateur à accès à ce dossier (s'il existe) et si un nom de document st testé alors vérifier l'existance ou non de ce dernier. Dans tout ça je bloque sur une partie, tester les droits d'accès au dossier.

Dans le code ci-dessous j'ai imaginé passé par CreateObject("Scripting.FileSystemObject") et .Attributes. Le truc c'est que sur le réseau, le code me retourne tout le temps vbDirectory comme attribute, et ça que j'ai accès au dossier ou non.

J'ai cherché alors une commande de type .Permissions mais sans succès. Comment pourai-je faire ? (j'aimerai aussi éviter de passer par un On error resume next car ça je sais le faire).

Par avance merci de l'interet porté au sujet

Sub test()
    Call FileExist("N:xxxx", "MonFichier.xlsm")
End Sub

Private Function FileExist(FolderPath As String, Optional FileName As String) As Boolean
Dim FSO As Object, FldPath As Object
Dim FldPermissions As Integer

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(FolderPath) = False Then 'Test si répertoire existe
        FileExist = False
        MsgBox "Le répertoire """ & FolderPath & """ & n'a pas été trouvé.", vbCritical
        Exit Function
    End If
    Set FldPath = FSO.GetFolder(FolderPath)
    FldPermissions = FldPath.Attributes
    If FldPermissions > 1 Then 'Si des autorisations sur le dossier
        FileExist = False
        MsgBox "Vous n'avez pas l'autorisation d'accéder à " & FolderPath & """. Contactez l'administrateur réseau pour demander l'accès.", vbCritical
        Exit Function
    End If

'vbNormal : 0
'vbReadOnly : 1
'vbHidden : 2
'vbSystem : 4
'vbVolume : 8
'vbDirectory : 16
'vbAlias : 64

End Function

Bonjour GGautier,

Bon je ne suis pas du tout administrateur réseau et mes connaissances en VBA sont moyennes, mais vous obtenez 0 en Debug.Print ? Ca ne correspond pas aux propriétés du dossier ?

Perso j'ai testé ça sur un fichier (je n'arrive pas à mettre des droits sur mon propre PC) :

Sub R_W()
Dim fso As Variant
Dim fls As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile("C:\Users\***\Desktop\A\Nouveau Feuille de calcul Microsoft Excel.xlsx")
If f.Attributes - 32 = 1 Then MsgBox "Fichier en lecture seule, vous ne pouvez pas le modifier", vbCritical
End Sub

Et ce code fonctionne sur ces propriétés car j'ai bien mon message d'erreur en cas de lecture seule cochée, et rien dans le cas contraire :

A voir si cela fonctionne pareil sur les folders (bien que j'ai des doutes sur le -32 ...)

J'espère que ça pourra peut être vous aiguiller ...

Cdlt,

Bonsoir,

trouvé sur le net :

'Tester la permission sur un répertoire
Public Function PermissionOK(strRepertoire As String) As Boolean
    On Error GoTo PermissionOK_Err

    Dim varPermission As Variant    'En utilisant la fonction DIR, si l'erreur 52 est retournée
                                    'cela signifie qu'on a pas accès au répertoire

    varPermission = Dir(strRepertoire & "UnnomdefichierALaCon.txt")
    'Peu importe ce qui est retourné, si on passe ici c'est qu'on a les droits
    'ou que rien n'existe
    PermissionOK = True
    Exit Function

PermissionOK_Err:
    'Si err 52 alors on a pas les droits sur le folder
    If Err.Number = 52 Then
        PermissionOK = False
    End If

End Function

Sub test()
    MsgBox PermissionOK("D:\_Applications Excel")
End Sub

Pour tester le "non droit" il faut soit avoir accès à un réseau avec des restriction soit ouvrir une nouvelle cession de son ordinateur en créant un deuxième utilisateur qui lui n'aurait pas tous les accès, sur mon ordi j'ai accès à tout, alors je n'ai pas réussi à "sortir le "FAUX"

@ bientôt

LouReeD

Bonsoir,

Autre proposition en utilisant le service WMI

Private Function FileExist(FolderPath As String, Optional FileName As String) As Boolean
    Dim FSO As Object, FldPath As Object, chemin As String
    Dim FldPermissions As Boolean
    Dim WMIService As Object, Sécurité As Object, ctrl_accès As Object
    Const strComputer As String = "."

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(FolderPath) = False Then 'Test si répertoire existe
        FileExist = False
        MsgBox "Le répertoire """ & FolderPath & """ & n'a pas été trouvé.", vbCritical
        Exit Function
    End If
    Set FldPath = FSO.GetFolder(FolderPath): chemin = Replace(FldPath.Path, "\", "\\")

    ' Connection au service WMI
    Set WMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    ' Récupération de l'onglet sécurité avec ses paramètres compilés pour le chemin considéré
    Set Sécurité = WMIService.ExecQuery("SELECT * FROM Win32_LogicalFileSecuritySetting WHERE Path= " & "'" & chemin & "'" & "")

    ' Récupération du contrôle d'accès de l'onglet sécurité pour le chemin considéré
    For Each ctrl_accès In Sécurité
        FldPermissions = ctrl_accès.OwnerPermissions
        If Not FldPermissions Then 'Si non autorisé sur le dossier
            FileExist = False
            MsgBox "Vous n'avez pas l'autorisation d'accéder à " & FolderPath & """. Contactez l'administrateur réseau pour demander l'accès.", vbCritical
            Exit Function
        End If
    Next ctrl_accès

End Function

Bonjour messieurs

Merci pour vos retours !

thev, c'est très intéressant, mais chez moi ça ne marche pas, j'ai fait un test sur un dossier auquel j'ai accès et il me retourne le message comme quoi je n'ai pas accès Il y a peut-être une subtilité dans le fait qu'il s'agisse d'un dossier sur un lecteur réseau ?

LouReeDC, Jusqu'ici je passais aussi par un système de on error resume next". Pour tester les droits au dossier je cherche à compter le nombre de dossier (cf extrait de code ci-dessous)

    Err.Number = 0
    Set FldPath = Fso.GetFolder(TestedFolderPath)
    On Error Resume Next
    CheckedAccess = FldPath.subfolders.Count
    If Err.Number <> 0 Then
        CheckedFolder = False
        If Err.Number = 70 Then
            MsgBox "Vous n'avez pas l'autorisation d'accéder à """ & TestedFolderPath & """. Contactez l'administrateur réseau pour demander l'accès.", vbCritical
        Else
            MsgBox "Une erreur s'est produite pendant l'accès à """ & TestedFolderPath & """.", vbCritical
        End If
        Exit Function
    Else
        On Error GoTo 0
    End If

Ergotamine, Je ne cherche pas à tester les permissions sur un fichier mais sur un dossier. Au final l'objectif est que n'import quel utilisateur utilisant ce code (et qui ne savent pas forcement quels sont les fichiers/sous dossiers présent) puisse tester leurs accès au dossier.

Bonjour,

c'est très intéressant, mais chez moi ça ne marche pas, j'ai fait un test sur un dossier auquel j'ai accès et il me retourne le message comme quoi je n'ai pas accès

Avec cette classe WMI, cela devrait mieux fonctionner

Private Function FileExist(FolderPath As String, Optional FileName As String) As Boolean
    Dim FSO As Object, FldPath As Object
    Dim FldPermissions As Boolean
    Dim WMIService As Object, répertoire As Object, item As Object
    Const strComputer As String = "."
    Dim unité As String, dossier As String

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(FolderPath) = False Then 'Test si répertoire existe
        FileExist = False
        MsgBox "Le répertoire """ & FolderPath & """ & n'a pas été trouvé.", vbCritical
        Exit Function
    End If

    ' détermination unité et dossier
    Set FldPath = FSO.GetFolder(FolderPath)
    unité = Split(FldPath.Path, ":")(0) & ":": dossier = Replace(Split(FldPath.Path, ":")(1) & "\", "\", "\\")
    ' Connection au service WMI
    Set WMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    ' Récupération du répertoire pour le chemin considéré
    Set répertoire = WMIService.ExecQuery("SELECT * FROM Win32_Directory WHERE Drive = " & "'" & unité & "'" & " AND  Path= " & "'" & dossier & "'" & "")
    FldPermissions = False
    ' Contrôle accès aux éléments du répertoire
    For Each item In répertoire
        FldPermissions = True: Exit For
    Next item

    If Not FldPermissions Then 'Si non autorisé sur le dossier
        FileExist = False
        MsgBox "Vous n'avez pas l'autorisation d'accéder à " & FolderPath & """. Contactez l'administrateur réseau pour demander l'accès.", vbCritical
        Exit Function
    End If

End Function

NB: à noter tout de même que si le dossier sélectionné ne contient rien, il sera considéré comme inaccessible.

Bonjour à tous...

petite remarque concernant les autorisations NTFS des dossiers.. en gros (car on peut faire bien plus compliqué) un utilisateur donné peut avoir les droits de lecture seulement du contenu du dossier. Soit le droit de modifier le contenu ( ajouter/ supprimer / modifier les fichiers) soit le contrôle total du dossier ( ce qui est peu probable si les autorisations sont biens faites) et là l'utilisateur peut aussi modifier les autorisations du dossier c'est-à-dire ajouter ou supprimer des utilisateurs au niveau des droits.

EDIT : soit pas de droits du tout... même pas celui de consulter le contenu du dossier...

Donc Ggautier tu recherche a récupérer quoi comme autorisation ? de lecture (lecture seule) ou de modification du dossier ?

Fred

Bonjour

et ben mes amis en voila un déploiement de force pour un detail de fichier ou dossier

juste une petite esquisse vite fait comme ça sans FSO

j'ai mis un txt dans mon dossier et je l'ai nommé "toto.txt"

je l'ai caché et en lecture seule pour le test

du pur VBA sans librairie externe

Sub test()
    Call FileExist("G:\vba excel", "toto.txt")
End Sub

Private Function FileExist(FolderPath As String, Optional FileName As String) As Boolean
    critere = vbDirectory Or vbHidden Or vbNormal Or vbArchive Or vbReadOnly Or vbSystem Or vbVolume
    d = Dir(FolderPath, critere)
    If d = "" Then MsgBox "le dossier n'existe pas": Exit Function
    e = Dir(FolderPath & "\" & FileName, critere)
    If e = "" Then MsgBox " le fichier n'exite pas": Exit Function
    attd = GetAttr(FolderPath)    'attribut du dossier
    attf = GetAttr(FolderPath & "\" & FileName)    ' attribut du fichier

    MsgBox attd & vbCrLf & attf    ' juste pour test pour voir

    texte = "Attribut du dossier" & vbCrLf
    n = attd - vbNormal = 16
    texte = texte & "normal :" & n

    ro = attd - vbReadOnly = 16
    texte = texte & vbCrLf & "lecture seule :" & ro

    h = attd - vbHidden = 16
    texte = texte & vbCrLf & "caché :" & h

    vs = attd - vbSystem = 16
    texte = texte & vbCrLf & "vbsystem :" & vs & vbCrLf

    texte = texte & vbCrLf & "Attribut du fichier" & vbCrLf

    n = attf = 32
    texte = texte & "normal :" & n

    ro = attf - vbReadOnly = 32
    texte = texte & vbCrLf & "lecture seule :" & ro

    h = attf - vbHidden = 32
    texte = texte & vbCrLf & "caché :" & h

    vs = attf - vbSystem = 32
    texte = texte & vbCrLf & "vbsystem :" & vs

    x = attf - vbHidden - vbReadOnly = 32
    texte = texte & vbCrLf & "caché et en lecture seule :" & x

    MsgBox texte

    'vbNormal : 0
    'vbReadOnly : 1
    'vbHidden : 2
    'vbSystem : 4
    'vbVolume : 8
    'vbDirectory : 16
    'vbAlias : 64

End Function

c'était juste comme ça en passant

pour ceux qui ne savaient pas

la procédure a faire est simple

les dossiers normaux c'est 16

les fichiers normaux c'est 32

les atribut sont indexé de sorte que l'assocation de plusieurs (2 ou plus) ne fasse jamais le même résultat

'vbNormal : 0
'vbReadOnly : 1
'vbHidden : 2
'vbSystem : 4
'vbVolume : 8
'vbDirectory : 16
'vbAlias : 64

vous pouvez essayer additionner plusieurs d'entre eux dans n'importe quel sens aucun n'aura le même résultat

il est alors facile de repérer quel attibuts sont appliquer au dossier ou fichier

atributbut du fichier - ce ci ou /et - cela =32

si c'est faux c'est que le ceci ou cela tester ne sont pas attribués

Bonjour

Suite test sur réseau avec des droits d'accès le code trouvé sur le net fait ce qu'il faut, c'est à dire retourner vrai si droit ouvert sur le dossier et faux dans le cas contraire...

@ bientôt

LouReeD

re

tiens pour le coup sur le modèle de ce matin , voila une petite fonction

j'ai nommé la fonction PropertyFolderFile

voila comme ca vous avez un retour textuel précis sur la situation administrative du dossier/fichier

à améliorer notamment le test filename<>"" avant le dir que j'ai zappé mille excuses

Sub test()
'MsgBox "fichier " & PropertyFolderFile("G:\vba excel", "toto.txt")' fichier caché en lecture seule 
'MsgBox "dossier " & PropertyFolderFile("G:\vba excel")'dossier normal 

    MsgBox "dossier " & PropertyFolderFile("G:\vba excel\titi")'dossier caché et en lecture seule 

End Sub

Private Function PropertyFolderFile(FolderPath As String, Optional FileName As String = "")
    Dim critere, d, e, AttF
    critere = vbDirectory Or vbHidden Or vbNormal Or vbArchive Or vbReadOnly Or vbSystem Or vbVolume

    d = Dir(FolderPath, critere)
    If d = "" Then MsgBox "le dossier n'existe pas": Exit Function

    e = Dir(FolderPath & "\" & FileName, critere)
    If e = "" Then MsgBox " le fichier n'exite pas": Exit Function

    AttF = GetAttr(FolderPath)    'attribut du dossier
    ' si fichier a analyser
    If FileName <> "" Then AttF = GetAttr(FolderPath & "\" & FileName)       ' attribut du fichier

    Select Case True
        'pour les dossiers
    Case AttF = 16: PropertyFolderFile = "Normal"
    Case AttF - vbReadOnly = 16: PropertyFolderFile = "lecture seule"
    Case AttF - vbHidden - vbReadOnly = 16: PropertyFolderFile = "caché et en lecture seule "
    Case AttF - vbHidden = 16: PropertyFolderFile = "caché"

        'pour les fichiers
    Case AttF = 32: PropertyFolderFile = "normal"
    Case AttF - vbReadOnly = 32: PropertyFolderFile = "lecture seule"
    Case AttF - vbHidden = 32: PropertyFolderFile = "caché "
    Case AttF - vbHidden - vbReadOnly = 32: PropertyFolderFile = "caché et en lecture seule"
    Case AttF - vbSystem = 32: PropertyFolderFile = "vbsystem "
    End Select

End Function

Bonjour à tous,

Merci pour vos propositions qui m'on l'air très complètes !!! Malheureusement je ne suis que de passage car je suis sur un projet d'avantage "prioritaire". Je ne vous laisse pas sans réponses, je reviendrais ici quand je plancherais à nouveau sur le sujet. Encore merci à vous ;)