siii perdón que no lo publique ;-)
<---------------------------------------------------------------------------------------------------------------------------->
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const FullAccessMask = 2032127, ModifyAccessMask = 1245631, WriteAccessMask = 118009
Const ROAccessMask = 1179817
strComputer = "."
sParentFolder = InputBox("Ingrese la ruta del directorio para capturar información", "Permisos de Carpetas")
InputMax = InputBox("Cantidad de registros máximo por reporte"+vbCrLf &+"(por defecto 20000, 4600 KB aprox.)",_
"Permisos de Carpetas - RegMax")
If InputMax="" then
InputMax=20000
End If
'Nombre de archivo sin caracteres especiales
SParentFoldern=replace(sParentFolder,"\","")
SParentFoldern=replace(sParentFoldern,":","_")
Set fso = CreateObject("Scripting.FileSystemObject")
'Variables de incremento
FileNum=1
RegNum=1
'Se crea archivo de datos para guardar consulta
fullfilename=SParentFoldern&+" ("+cstr(FileNum)+").csv"
Set fsOut = fso.OpenTextFile(fullfilename, ForAppending, True)
On Error Resume Next
fsOut.Writeline ("Directorio;Usuario/Grupo [Permisos] =>")
fsout.Close
ShowSubFolders FSO.GetFolder(sParentFolder),fullfilename
MsgBox sParentFolder& + vbCrLf & + "¡Listo!",,"Permisos de Carpetas - Proceso"
WScript.Quit
'--------------------------------------------------------------------
Public Sub OutputFolderInfo(FolderName , sOutfile, RegMax)
'Validar largo de la subcarpeta (menos de 190 caracteres)
Const LenMax = 190
If len(FolderName)<LenMax Then
Const FullAccessMask = 2032127, ModifyAccessMask = 1245631, WriteAccessMask = 1180095
Const ROAccessMask = 1179817
Const ForReading = 1, ForWriting = 2, ForAppending = 8
strComputer = "."
'Preparar rutas de archivo con doble backslash
folderpath = Replace(FolderName, "\", "\\")
objectpath = "winmgmts:Win32_LogicalFileSecuritySetting.path='" & folderpath & "'"
'Obtener conjunto de seguridad para el objeto
Set wmiFileSecSetting = GetObject(objectpath)
'Verificando obtención correcta
RetVal = wmiFileSecSetting.GetSecurityDescriptor(wmiSecurityDescriptor)
If Err Then
MsgBox ("Error en GetSecurityDescriptor" & 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
'Recuperar matriz DACL de Win32_ACE objects.
DACL = wmiSecurityDescriptor.DACL
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsOut = fso.OpenTextFile(sOutfile, ForAppending, True)
fsOut.Write (chr(34) & objFolder.Name & chr(34) & ";")
Cnt=0
For Each wmiAce In DACL
'Obtener objeto Win32_Trustee desde ACE
Set Trustee = wmiAce.Trustee
'Dominio\Grupo o Usuario [Permiso]
fsOut.Write (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.Write (" [" & AccessType & "];")
Else
fsOut.Write (" [" & "Custom" & "];")
End If
RegNum=RegNum+1
Cnt=Cnt+1
Next
fsOut.Write (vbCr)
'Si cantidad de registros supera a RegMax, se generan segmentos de archivos.
If RegNum>CInt(RegMax) Then
fsOut.Close
FileNum=FileNum+1
fullfilename=SParentFoldern&+" ("+cstr(FileNum)+").csv"
Set fsOut = fso.OpenTextFile(fullfilename, ForAppending, True)
RegNum=1
fsOut.Writeline ("Directorio;Usuario/Grupo [Permisos] =>")
End If
Set fsOut = Nothing
Set fso = Nothing
Next
Else
'MsgBox (FolderName+vbCrLf &+len(FolderName),,"Permisos de Carpetas - Directorio supera el largo permitido")
End If
Set fsOut = Nothing
Set fso = Nothing
end Sub
'Explorar subcarpetas
Sub ShowSubFolders (Folder,fname)
On Error Resume Next
For Each Subfolder in Folder.SubFolders
Call OutputFolderInfo(Subfolder.Path,fname,InputMax)
call ShowSubFolders (Subfolder,fname)
Next
End Sub
Login | Register
