VB to display folder permissions

Sub Main()
Dim filename_var As String
 
Dim strRemoteServerName As String
Dim strRemoteShareName As String
Dim strDefaultDomain As String
Dim strSystemDomainName As String
Dim strSystemDomainSid As String
 
Dim actualDirPath As String
Dim displayDirPath As String
Dim initialfilenameAbsPath As String
 
Dim fso As Scripting.FileSystemObject
 
Dim objLocator As WbemScripting.SWbemLocator
Dim objService As WbemScripting.SWbemServices
Dim objFileShare As WbemScripting.SWbemObject
 
Dim objFileSecSetting As WbemScripting.SWbemObject
Dim objSecDescriptor As Variant
Dim objOutParams As WbemScripting.SWbemObject
Dim objDACL_Member As Variant
Dim objtrustee As Variant
 
On Error GoTo OOPS
 
filename_var = "\\MYSERVER\myShareFolder"
 
'----------------------------------------
'set main variables
'----------------------------------------
GetServerNameString filename_var, strRemoteServerName,
strRemoteShareName
 
Set fso = New Scripting.FileSystemObject
 
Set objLocator = New WbemScripting.SWbemLocator
Set objService = objLocator.ConnectServer(strRemoteServerName,
"root/cimv2")
objService.Security_.ImpersonationLevel =
wbemImpersonationLevelImpersonate
objService.Security_.Privileges.AddAsString "SeSecurityPrivilege", True
 
Set objFileShare = objService.Get("Win32_Share.Name=""" &
strRemoteShareName & """")
actualDirPath = objFileShare.Path
displayDirPath = "\\" & strRemoteServerName & "\" & strRemoteShareName
 
initialfilenameAbsPath = fso.GetAbsolutePathName(Replace(filename_var,
displayDirPath, actualDirPath, 1, 1, 1))
 
'----------------------------------------
'check trustee
'----------------------------------------
GetDefaultNames objService, strDefaultDomain, strSystemDomainName
GetDefaultDomainSid objService, strSystemDomainSid, strSystemDomainName
 
Set objFileSecSetting =
objService.Get("Win32_LogicalFileSecuritySetting.Path=""" &
Replace(initialfilenameAbsPath, "\", "\\") & """")
Set objOutParams =
objFileSecSetting.ExecMethod_("GetSecurityDescriptor")
Set objSecDescriptor = objOutParams.Descriptor
 
If IsArray(objSecDescriptor.DACL) Then
For Each objDACL_Member In objSecDescriptor.DACL
Set objtrustee = objDACL_Member.Trustee
Debug.Print objtrustee.Domain & "\" & objtrustee.Name
Next
Else
Debug.Print "No permission defined"
End If
 
Set objSecDescriptor = Nothing
Set objOutParams = Nothing
Set objFileSecSetting = Nothing
Set objFileShare = Nothing
Set objService = Nothing
Set objLocator = Nothing
Set fso = Nothing
Exit Sub
 
OOPS:
Debug.Print "Error: " & Err.Number
Debug.Print "Source: " & Err.Source
Debug.Print "Description: " & Err.Description
End Sub
 
Private Function GetServerNameString(ByVal strFilePath As String, ByRef
strServerName As String, ByRef strShareName As String) As Boolean
Dim timeStart As Date
Dim timeEnd As Date
 
Dim strTempServer As String
Dim intShareStart As Long
Dim intShareEnd As Long
On Error Resume Next
GetServerNameString = False
If strFilePath = "" Then Exit Function
If Left(strFilePath, 2) <> "\\" Then Exit Function
If Len(strFilePath) < 3 Then Exit Function
strTempServer = Mid(strFilePath, 3)
intShareStart = InStr(1, strTempServer, "\", 1)
If intShareStart > 0 Then
strServerName = Left(strTempServer, intShareStart - 1)
strShareName = Mid(strTempServer, intShareStart + 1)
intShareEnd = InStr(1, strShareName, "\", 1)
If intShareEnd > 0 Then
strShareName = Left(strShareName, intShareEnd - 1)
End If
Else
strServerName = strTempServer
End If
GetServerNameString = True
End Function
 
Private Sub GetDefaultNames(ByRef objService As WbemScripting.SWbemServices,
ByRef strDefaultDomain As String, ByRef strSystemDomainName As String)
 
Const CONST_USE_LOCAL_FOR_NON_DCs = True
Dim objSystemSet As SWbemObjectSet
Dim objSystem As SWbemObject
Dim intRole As Long
On Error Resume Next
 
Set objSystemSet = objService.ExecQuery("SELECT Name, Domain, DomainRole
FROM Win32_ComputerSystem", , 0)
 
For Each objSystem In objSystemSet
If objSystem.Name <> "" Then
If objSystem.Domain <> "" Then
strSystemDomainName = objSystem.Domain
Else
strSystemDomainName = objSystem.Name
End If
intRole = objSystem.DomainRole
Select Case intRole
Case 0 'Standalone Workstation
strDefaultDomain = objSystem.Name
Case 1 'Member Workstation
If CONST_USE_LOCAL_FOR_NON_DCs Then
strDefaultDomain = objSystem.Name
Else
strDefaultDomain = objSystem.Domain
End If
Case 2 'Standalone Server
strDefaultDomain = objSystem.Name
Case 3 'Member Server
If CONST_USE_LOCAL_FOR_NON_DCs Then
strDefaultDomain = objSystem.Name
Else
strDefaultDomain = objSystem.Domain
End If
Case 4 'Backup Domain Controller
strDefaultDomain = objSystem.Domain
Case 5 'Primary Domain Controller
strDefaultDomain = objSystem.Domain
Case Else 'Don't know this one...so do nothing
strDefaultDomain = ""
End Select
Exit For
End If
Next
Set objSystem = Nothing
Set objSystemSet = Nothing
End Sub
 
Private Sub GetDefaultDomainSid(ByRef objService As
WbemScripting.SWbemServices, ByRef strSystemDomainSid As String, ByVal
strSystemDomainName As String)
Dim objSystemSet As SWbemObjectSet
Dim objSystem As SWbemObject
Dim strQuery As String
 
strSystemDomainSid = ""
strQuery = "SELECT Sid FROM Win32_Group WHERE Domain=""" &
strSystemDomainName & """ and Name=""Domain Admins"""
 
Set objSystemSet = objService.ExecQuery(strQuery, , 0)
 
For Each objSystem In objSystemSet
If objSystem.Sid <> "" Then
If Left(objSystem.Sid, 6) = "S-1-5-" And Right(objSystem.Sid, 4) =
"-512" Then
strSystemDomainSid = Mid(objSystem.Sid, 7)
strSystemDomainSid = Left(strSystemDomainSid,
Len(strSystemDomainSid) - 4)
Exit For
End If
End If
Next
 
Set objSystem = Nothing
Set objSystemSet = Nothing
End Sub