............ Foro Excel
Si no lo has hecho aún: REGISTRATE!!!

Listar Archivos de una Carpeta y sus SubCarpetas con FileSystemObject

Ver el tema anterior Ver el tema siguiente Ir abajo

Listar Archivos de una Carpeta y sus SubCarpetas con FileSystemObject

Mensaje por GalileoGali el Dom Abr 20, 2008 7:15 pm

Andaba preparando algo sencillo, pero no lo terminé. Como en otros foros hay quienes reclaman un Listador de Ficheros compatible con Excel2007 y los que utilizan FileSearch no pueden correr bajo Xl2007. Traigo aqui, con algunas adaptaciones minimas una macro de JPG (Juan Pablo Gonzalez MrExcel MVP, y si aprobo el examen el año pasado ya debe ser MVP MS)

Código:
Option Explicit

Private fsoSystem As FileSystemObject

'____________________
Sub ListFolderSizes()
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
' Based on code posted by JPG here:
' http://www.mrexcel.com/board2/viewtopic.php?t=51719
   
    Dim strStartPath As String, strToAbbr As String
    Dim varFileInfo() As Variant
    Dim booSubFolders As Boolean, booListFiles As Boolean
    Dim rngCurrent As Range, rngCell As Range, rngCol As Range
    Dim p%
   
    Set fsoSystem = New FileSystemObject
   
    strStartPath = GetStartPath
    booSubFolders = False
    'booSubFolders = (vbYes = MsgBox("Incluir Sub-Carpetas?", vbYesNo + vbQuestion))
    booListFiles = True
    'booListFiles = (vbYes = MsgBox("Listar Archivos?", vbYesNo + vbQuestion + vbDefaultButton2))
   
   
    ReDim varFileInfo(1 To 2, 1 To 1)
    varFileInfo(1, 1) = "Nombre de Carpeta"
    varFileInfo(2, 1) = "Tamaño Carpeta"
    GetFolderInfo varFileInfo, strStartPath, booSubFolders, booListFiles
    Set fsoSystem = Nothing
    Range("A1").Resize(UBound(varFileInfo, 2), 2).Value = Application.Transpose(varFileInfo)
    Application.StatusBar = False
    If Not booSubFolders Then Exit Sub
    Set rngCurrent = [a1].CurrentRegion
    rngCurrent.Font.Name = "Courier New"
    rngCurrent.Sort Key1:=Range("A1"), Header:=xlYes
    rngCurrent.Columns(3).FormulaR1C1 = "=(LEN(RC[-2]) - LEN(SUBSTITUTE(RC[-2],""\"","""")))"
    [C1].FormulaR1C1 = "=MAX(R[1]C:R[" & rngCurrent.Rows.Count - 1 & "]C)"
    rngCurrent.Columns(2).NumberFormat = _
        "[Black][>1000000]#,###.0,,"" MB"";[Blue][>1000]#.0,"" KB"";[Magenta]0 "" B"""
    If [C2] > 1 Then
        Set rngCol = rngCurrent.Columns(1)
        Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
        strToAbbr = Mid(strStartPath, 1, InStrRev(Left(strStartPath, Len(strStartPath) - 1), _
                    Application.PathSeparator))
        rngCol.Replace what:=strToAbbr, _
                      Replacement:=Left(strToAbbr, 2) & "..\", _
                      LookAt:=xlPart
    End If
    With rngCurrent.Columns(3)
        .Formula = .Value
    End With
    Set rngCol = rngCurrent.Columns(1)
    Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
    '// Anything that's missing a period (no file extension)
    '// is assumed to be a folder (not 100% accurate, but close)
    If booListFiles Then
'        With rngCol.FormatConditions
'            .Delete
'            .Add Type:=xlExpression, _
'                Formula1:="=ISERROR(SEARCH(""."",A1))"
'            With .Item(1).Font
'                .Bold = True
'                .Italic = False
'                .ColorIndex = 5    'blue
'            End With
'        End With
    End If
    Set rngCol = rngCol.Offset(1).Resize(rngCol.Rows.Count - 1)
    For Each rngCell In rngCol.Cells
        With rngCell
            p = InStrRev(.Value, Application.PathSeparator)
            .Value = Space(p - 1) & Right(.Text, Len(.Text) - p + 1)
            .Offset(, 1).Cut .Offset(, .Offset(, 2))
            If .Offset(, 2).NumberFormat = "General" Then .Offset(, 2).Clear
        End With
    Next rngCell
    [C1:C2].Clear
   
End Sub

'__________________________________________________
Sub GetFolderInfo(ByRef varFileInfo As Variant, _
                  ByVal strFolder As String, _
                  ByVal booSubFolders As Boolean, _
                  ByVal booListFiles As Boolean)
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Dim fsoFolder As scripting.Folder, fsoSubFolder As scripting.Folder
    Dim fsoFile As scripting.File
    Dim lngFolderCount As Long
   
    On Error GoTo err_GetFolderInfo
    Set fsoFolder = fsoSystem.GetFolder(strFolder)
    lngFolderCount = UBound(varFileInfo, 2) + 1
    ReDim Preserve varFileInfo(1 To 2, 1 To lngFolderCount)
    varFileInfo(1, lngFolderCount) = fsoFolder.Path
    varFileInfo(2, lngFolderCount) = fsoFolder.Size
    On Error GoTo 0
    If booListFiles Then
        For Each fsoFile In fsoFolder.Files
            lngFolderCount = UBound(varFileInfo, 2) + 1
            Application.StatusBar = "Items Found: " & lngFolderCount
            ReDim Preserve varFileInfo(1 To 2, 1 To lngFolderCount)
            varFileInfo(1, lngFolderCount) = fsoFile.Path
            varFileInfo(2, lngFolderCount) = fsoFile.Size
        Next fsoFile
    End If
       
    If booSubFolders Then
        On Error GoTo err_GetFolderInfo
        For Each fsoSubFolder In fsoFolder.SubFolders
            If Not fsoSubFolder Is Nothing Then
                GetFolderInfo varFileInfo, fsoSubFolder.Path, True, booListFiles
            End If
        Next fsoSubFolder
    End If
    Set fsoFolder = Nothing
    Exit Sub

err_GetFolderInfo:
'¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨¨

    Select Case Err.Number
        Case 70        ' (permission denied)
            varFileInfo(2, lngFolderCount) = 1
            Resume Next
        Case Else
            MsgBox "Error # " & Err.Number & ": " & Err.Description
    End Select
End Sub

'________________________________________
Private Function GetStartPath() As String
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
    Dim strDir As String, strPS As String
    Dim fdDir As FileDialog
   
    strPS = Application.PathSeparator
    Set fdDir = Application.FileDialog(msoFileDialogFolderPicker)
   
    [a1].Select
    If ActiveCell = "" Then
        fdDir.InitialFileName = Application.DefaultFilePath & strPS
    Else
        fdDir.InitialFileName = [a1]
    End If
   
    With fdDir
        If .Show = 0 Then Exit Function
        strDir = .SelectedItems(1)
    End With
   
    GetStartPath = strDir & IIf(Right(strDir, 1) <> strPS, strPS, vbNullString)
       
End Function

[Tienes que estar registrado y conectado para ver este vínculo]


Última edición por GalileoGali el Sáb Sep 20, 2008 9:42 am, editado 2 veces

_________________
GalileoGali
M.A.P. 2010-2013
Microsoft Active Professional
avatar
GalileoGali
Admin

Masculino Cantidad de envíos : 1963
Edad : 62
Ciudad - Pais : QUIROGA, Argentina
Version de Excel : 2000-2003-2007-2010
Fecha de inscripción : 24/01/2008

http://excelgali.mejorforo.net

Volver arriba Ir abajo

Re: Listar Archivos de una Carpeta y sus SubCarpetas con FileSystemObject

Mensaje por federico ramirez marron el Jue Abr 24, 2008 2:07 pm

No puedo descargar este archivo de snips, se ve muy interesantisimo!!!
avatar
federico ramirez marron

Masculino Cantidad de envíos : 95
Edad : 44
Ciudad - Pais : acapulco, gro mexico
Fecha de inscripción : 03/03/2008

Volver arriba Ir abajo

Re: Listar Archivos de una Carpeta y sus SubCarpetas con FileSystemObject

Mensaje por GalileoGali el Jue Abr 24, 2008 5:50 pm

Federico: prueba ahora a ver si esta solucionado....

_________________
GalileoGali
M.A.P. 2010-2013
Microsoft Active Professional
avatar
GalileoGali
Admin

Masculino Cantidad de envíos : 1963
Edad : 62
Ciudad - Pais : QUIROGA, Argentina
Version de Excel : 2000-2003-2007-2010
Fecha de inscripción : 24/01/2008

http://excelgali.mejorforo.net

Volver arriba Ir abajo

Re: Listar Archivos de una Carpeta y sus SubCarpetas con FileSystemObject

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba


 
Permisos de este foro:
No puedes responder a temas en este foro.