troubleshooting Question

vba code to read ntfs permissions on the root path only

Avatar of benevolentanarchist
benevolentanarchist asked on
ProgrammingMicrosoft Development
3 Comments1 Solution2732 ViewsLast Modified:
I need VBA code that will read/retrieve NTFS permissions on a specified folder. I found this great VBS code that accepts a path and retrieves permissions from all subfolders. (it does not return the permissions for the specified path, only subfolders).

I am only concerned with retrieving permissions from the specified path and not concerned with the subfolders.

Unfortunately I am not a programmer so I have no idea how to modify this code to fit my needs. Can anyone help? I actually need the code to run in VBA (Excel).

Thanks in advance to anyone who can assist.
'Create instance of Shell Object:
'================================
Set objShell = CreateObject("Wscript.shell")
Set voice = CreateObject("SAPI.Spvoice")
Text = "Please wait. Enumerating Discretionary Access Control List for the folders"
 
'Creating Excel Instance:
'========================
 
Set excelinstance = CreateObject("Excel.application")
excelinstance.Workbooks.Add
excelinstance.Visible = True
 
'Creating Columns:
'==================
 
excelinstance.Cells(1, 1).Value = "Folders"
excelinstance.Cells(1, 2).Value = "Domain"
excelinstance.Cells(1, 3).Value = "Users/Groups"
 
 
'Starting from Second Row:
'=========================
 
m = 2
 
 
'Setting properties for columns:
'================================
 
Set Range = excelinstance.Range("A1", "C1")
Range.Font.Size = 12
Range.Font.Bold = True
Range.Interior.ColorIndex = 6
Range.Font.Name = "Times New Roman"
Range.ColumnWidth = 20
 
 
'WMI Code:
'=========
 
strcomputer = "."
 
 
'Specify the path for the share:
'================================
 
strpathname = "c:\temp"
 
voice.Speak Text
objShell.Popup "Please wait....Enumerating Discretionary Access Control List for the folders", 5
'Calling Swbemservices Object:
'=============================
 
Set x = GetObject("winmgmts:\\" & strcomputer & "\root\cimv2")
 
Set Folders = x.ExecQuery("Associators of {Win32_Directory.Name='" & strpathname & "'} " _
                          & "Where AssocClass = Win32_Subdirectory " _
                          & "ResultRole = PartComponent")
                 
For Each subfolder In Folders
 
	Getsubfolders strpathname
	
Next
 
'Sub Function for Recursive Enumeration of Folders:
'======================================
 
Sub Getsubfolders(strpathname)
 
Set folders1 = x.ExecQuery ("Associators of {Win32_Directory.Name='" & strpathname & "'} " _
                            & "Where AssocClass = Win32_Subdirectory " _
                            & "ResultRole = PartComponent")
 
For Each subfolders1 In folders1
 
	strpathname = subfolders1.Name
 
	excelinstance.Cells(m, 1) = strpathname
	excelinstance.Cells(m, 1).ColumnWidth = 70
	excelinstance.Cells(m, 1).Font.Name = "Times New Roman"
 
 
	'Enumerating DACL's for each folder:
	'====================================
 
	Set objFolderSecuritySettings = _
	x.Get("Win32_LogicalFileSecuritySetting='" & strpathname & "'")
	returncode = objFolderSecuritySettings.GetSecurityDescriptor(SD)
 
	If returncode = 0 Then
 
		colaccess = SD.DACL
		For Each objaccess In colaccess
			excelinstance.Cells(m, 2) = objaccess.trustee.domain
			excelinstance.Cells(m, 2).ColumnWidth = 40
			excelinstance.Cells(m, 2).Font.Name = "Times New Roman"
 
			excelinstance.Cells(m, 3) = objaccess.trustee.Name
			excelinstance.Cells(m, 3).ColumnWidth = 50
			excelinstance.Cells(m, 3).Font.Name = "Times New Roman"
 
			m = m + 1
			Getsubfolders strpathname
		
		Next
 
	Else

		excelinstance.Cells(m, 2).Value = "DACL could not be retrieved"
		excelinstance.Cells(m, 3).Value = "DACL could not be retrieved"
 
	End If
 
Next
 
End Sub
ASKER CERTIFIED SOLUTION
David Johnson, CD
The More I know, the more I don't know
Join our community to see this answer!
Unlock 1 Answer and 3 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 3 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros