Listing folder permissions nearly there but needs tidy up

madmiddle

New Member
Joined
Mar 8, 2012
Messages
45
Good afternoon,

I have been tasked with trying to find out the permissions on a set of folders on a company network. I know write vba code to manipulate a excel spreadsheet without any problems, but it is when i'm using objects that it starts to go beyond my capability. whilst searching i found this code:

Code:
Sub test1()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
 
Const FullAccessMask = 2032127, ModifyAccessMask = 1245631, WriteAccessMask = 118009
Const ROAccessMask = 1179817
 
 
 
strComputer = "."
sParentFolder = InputBox("Please Enter folder to gather information on", "Parent Folder")
SParentFoldern = Replace(sParentFolder, "\", "")
SParentFoldern = Replace(SParentFoldern, ":", "")
Set fso = CreateObject("Scripting.FileSystemObject")
'File name Same As Folder Name without special Caracteres
fullfilename = SParentFoldern & ".html"
'WScript.echo fullfilename
 
Set fsOut = fso.OpenTextFile(fullfilename, ForAppending, True)
 
On Error Resume Next
 
fsOut.Writeline ("" & vbCr & "" & vbCr & "" & vbCr & "")
 
strTableHead = [COLOR=#800000]"<table border=2 bordercolor='#000010' width='90%' id='Table1'>"[/COLOR] 

                 
fsOut.Close
 
 
 
ShowSubFolders fso.GetFolder(sParentFolder), fullfilename
 
OutputFolderInfo sParentFolder, fullfilename
 
Set fsOut = fso.OpenTextFile(fullfilename, ForAppending, True)
fsOut.Writeline strTableFoot
fsOut.Close
MsgBox "Done "
Wscript.Quit
End Sub
Public Sub OutputFolderInfo(FolderName, sOutfile)
 
Const FullAccessMask = 2032127, ModifyAccessMask = 1245631, WriteAccessMask = 1180095
Const ROAccessMask = 1179817
Const ForReading = 1, ForWriting = 2, ForAppending = 8
 
strComputer = "."
 
'Build the path to the folder because it requites 2 backslashes
folderpath = Replace(FolderName, "\", "\\")
 
objectpath = "winmgmts:Win32_LogicalFileSecuritySetting.path='" & folderpath & "'"
 
'Get the security set for the object
Set wmiFileSecSetting = GetObject(objectpath)
 
'verify that the get was successful
RetVal = wmiFileSecSetting.GetSecurityDescriptor(wmiSecurityDescriptor)
 If Err Then
     MsgBox ("GetSecurityDescriptor failed" & vbCrLf & Err.Number & vbCrLf & Err.Description)
     Err.Clear
 End If
 
 
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & _
    strComputer & "\root\cimv2")
Set colFolders = objWMIService.ExecQuery("SELECT * FROM Win32_Directory WHERE Name ='" & _
    folderpath & "'")
For Each objFolder In colFolders
     
    ' Retrieve the DACL array of Win32_ACE objects.
    DACL = wmiSecurityDescriptor.DACL
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsOut = fso.OpenTextFile(sOutfile, ForAppending, True)
     
 
    For Each wmiAce In DACL
    ' Get Win32_Trustee object from ACE
        Set Trustee = wmiAce.Trustee
        fsOut.Writeline "[TR]
[TD="width: 50%"]" & objFolder.Name & "[/TD]
" & _
                "[TD="width: 50%"]" & Trustee.Domain & "\" & Trustee.Name & "[/TD]
"
 
        'fsOut.Write objFolder.Name & "," & Trustee.Domain & "\" & Trustee.Name & ","
        FoundAccessMask = False
        CustomAccessMask = Flase
        While Not FoundAccessMask And Not CustomAccessMask
            If wmiAce.AccessMask = FullAccessMask Then
                AccessType = "Full Control"
                FoundAccessMask = True
            End If
            If wmiAce.AccessMask = ModifyAccessMask Then
                AccessType = "Modify"
                FoundAccessMask = True
            End If
            If wmiAce.AccessMask = WriteAccessMask Then
                AccessType = "Read/Write Control"
                FoundAccessMask = True
            End If
            If wmiAce.AccessMask = ROAccessMask Then
                AccessType = "Read Only"
                FoundAccessMask = True
            Else
                CustomAccessMask = True
            End If
        Wend
       
        If FoundAccessMask Then
            'fsOut.Writeline AccessType
            fsOut.Writeline "[TD="width: 50%"]" & AccessType & "[/TD]
[/TR]
"
        Else
             fsOut.Writeline "[TD="width: 50%"]Custom[/TD]
</TR>"
            'fsOut.Writeline "Custom"
        End If
        
    Next
 
    Set fsOut = Nothing
    Set fso = Nothing
 
Next
 
Set fsOut = Nothing
Set fso = Nothing
 
End Sub
Sub ShowSubFolders(Folder, fname)
On Error Resume Next
    For Each Subfolder In Folder.SubFolders
        Call OutputFolderInfo(Subfolder.Path, fname)
        Wscript.Echo Subfolder.Path
        Call ShowSubFolders(Subfolder, fname)
    Next
End Sub


It does a perfect job but puts the data into an html file. i managed to get it to input the data into the spreadsheet as well but i would like to clean this code up so that it is not producing another file (namely the text file or the html file) and just put the results into the excel file I have entered the module into.

I did start to remove the references to any file name, but that is where i run into trouble and it wouldn't run any more due to object not found.

I'm on Win 7 using Office 2010

Thank you in advance

Andy
 
Last edited:

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

madmiddle

New Member
Joined
Mar 8, 2012
Messages
45
It does a perfect job but puts the data into an html file. i managed to get it to input the data into the spreadsheet as well but i would like to clean this code up so that it is not producing another file (namely the text file or the html file) and just put the results into the excel file I have entered the module into.
I did start to remove the references to any file name, but that is where i run into trouble and it wouldn't run any more due to object not found.
I'm on Win 7 using Office 2010
Thank you in advance
Andy
 

Watch MrExcel Video

Forum statistics

Threads
1,129,577
Messages
5,637,201
Members
416,960
Latest member
Carbon1198

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top