Listing folder permissions nearly there but needs tidy up

[madmiddle]

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:

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

 

[madmiddle]

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