Listar archivos presentes dentro de una carpeta
Hola
Tengo varias carpetas, cada una con el nombre de un cliente, y dentro de ellas diferentes archivos (pdf,doc.,xls). Es posible que excel me cree una lista con los nombres de los archivos y me permita realizar busquedas de estos?
Agradezco de antemano tu ayuda
Pedro
Tengo varias carpetas, cada una con el nombre de un cliente, y dentro de ellas diferentes archivos (pdf,doc.,xls). Es posible que excel me cree una lista con los nombres de los archivos y me permita realizar busquedas de estos?
Agradezco de antemano tu ayuda
Pedro
Respuesta de blooddragon
1
1
Esta es la macro le das un path y el tipo de archivo a buscar *.* te trai todos en una hoja y te traia un listado de todos los archivos carpetas y subcarpetas
Option Explicit
Dim j As Long
'Sub Leer_directorio()
' Dim Archivo As String
' Dim i As Integer
'
' Archivo = Dir("C:\JM\01\Archivos Sin respaldo\Musica\")
'
' i = 1
' While Archivo <> ""
' i = i + 1
' Archivo = Dir
' ActiveWorkbook.Sheets("Leer").Activate
' ActiveSheet.Cells(i, 2).Value = Archivo
' Wend
'End Sub
'*********************************************************************************************************
'------------------------------------------------------------------------------
'Declaraciones del Api
'------------------------------------------------------------------------------
'Esta función busca el primer archivo de un Dir
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
'Esta el siguiente archivo o directorio
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
ByVal lpFileName As String) As Long
'Esta cierra el Handle de búsqueda
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
' Constantes
'------------------------------------------------------------------------------
'Constantes de atributos de archivos
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Otras constantes
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
'UDT
'------------------------------------------------------------------------------
'Estructura para las fechas de los archivos
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'Estructura necesaria para la información de archivos
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Type T_Tag_Mp3
Header As String * 3
SongTitle As String * 30
Artist As String * 30
Album As String * 30
Year As String * 4
Comment As String * 30
Genre As Byte
End Type
Sub Busca_Archivos()
Dim Path As String
Dim Pattern As String
Dim FileSize As Currency
Dim Count_Archivos As Long
Dim Count_Dir As Long
ActiveWorkbook.Sheets("Leer").Activate
'Path y archivos a buscar
Path = ActiveSheet.Cells(1, 1).Value
Pattern = ActiveSheet.Cells(1, 2).Value
j = 2
'Llamamos a la función para buscar y que nos retorne algunos datos
FileSize = Encuentra_Archivos_API(Path, Pattern, Count_Archivos, Count_Dir)
'Mostramos los resultados
'Cantidad de archivos encontrados
MsgBox Count_Archivos & " Archivos encontrados en " & Count_Dir & " Directorios", 64
'Tamaño Total en Bytes de los archivos encontrados
MsgBox "Tamaño total de los archivos: " & Path & " = " & _
Format(FileSize, "#,###,###,##0") & " Bytes", 64
End Sub
Private Function Encuentra_Archivos_API(Path As String, SearchStr As String, _
FileCount As Long, DirCount As Long)
On Error GoTo EH
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Long
Dim i, Archivo As Long
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Long
Dim ar As String
Dim Ext As String
Dim Un_Tag As T_Tag_Mp3
If Right(Path, 1) <> "\" Then Path = Path & "\"
' Buscamos por mas directorios
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(Path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = Eliminar_Nulos(WFD.cFileName)
' Ignora estos directorios
If (DirName <> ".") And (DirName <> "..") Then
' revisa el directrio
If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
Loop
Cont = FindClose(hSearch)
End If
hSearch = FindFirstFile(Path & SearchStr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
FileName = Eliminar_Nulos(WFD.cFileName)
If (FileName <> ".") And (FileName <> "..") Then
Encuentra_Archivos_API = Encuentra_Archivos_API + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
FileCount = FileCount + 1
ActiveWorkbook.Sheets("Leer").Activate
j = j + 1
If j > 64999 Then
MsgBox "Existen demasiados archivos por favor seleccione una ruta mas corta", vbOKOnly + vbCritical, _
"ERROR"
End
End If
ActiveSheet.Cells(j, 1).Value = Path
ActiveSheet.Cells(j, 2).Value = FileName
Ext = Right(FileName, 4)
If Left(Ext, 1) = "." Then
ActiveSheet.Cells(j, 3).Value = Ext
End If
If Ext = ".mp3" Or Ext = ".wma" Then
ar = Path & FileName
Archivo = FreeFile
Open ar For Binary Access Read As Archivo
Get Archivo, LOF(1) - 127, Un_Tag
Close Archivo
ActiveSheet.Cells(j, 4).Value = Eliminar_Nulos(Un_Tag.Album)
ActiveSheet.Cells(j, 5).Value = Eliminar_Nulos(Un_Tag.Artist)
ActiveSheet.Cells(j, 6).Value = Eliminar_Nulos(Un_Tag.Comment)
ActiveSheet.Cells(j, 7).Value = Eliminar_Nulos(Un_Tag.Genre)
ActiveSheet.Cells(j, 8).Value = Eliminar_Nulos(Un_Tag.Header)
ActiveSheet.Cells(j, 9).Value = Eliminar_Nulos(Un_Tag.SongTitle)
ActiveSheet.Cells(j, 10).Value = Eliminar_Nulos(Un_Tag.Year)
End If
End If
Cont = FindNextFile(hSearch, WFD)
Wend
Cont = FindClose(hSearch)
End If
' Si estos son Sub Directorios......
If nDir > 0 Then
For i = 0 To nDir - 1
Encuentra_Archivos_API = Encuentra_Archivos_API + Encuentra_Archivos_API(Path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount)
Next i
End If
Exit Function
EH:
Select Case Err.Number
Case 1004:
Resume Next
Case 63
Resume Next
Case Else:
MsgBox Err.Number & "-" & Err.Description, vbOKOnly + vbCritical
Resume
End Select
End Function
'Esta función es para formatear los nombres de archivos y directorios. Elimina los CHR(0)
'------------------------------------------------------------------------
Function Eliminar_Nulos(ByVal OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
Eliminar_Nulos = OriginalStr
End Function
Option Explicit
Dim j As Long
'Sub Leer_directorio()
' Dim Archivo As String
' Dim i As Integer
'
' Archivo = Dir("C:\JM\01\Archivos Sin respaldo\Musica\")
'
' i = 1
' While Archivo <> ""
' i = i + 1
' Archivo = Dir
' ActiveWorkbook.Sheets("Leer").Activate
' ActiveSheet.Cells(i, 2).Value = Archivo
' Wend
'End Sub
'*********************************************************************************************************
'------------------------------------------------------------------------------
'Declaraciones del Api
'------------------------------------------------------------------------------
'Esta función busca el primer archivo de un Dir
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long
'Esta el siguiente archivo o directorio
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" ( _
ByVal lpFileName As String) As Long
'Esta cierra el Handle de búsqueda
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
' Constantes
'------------------------------------------------------------------------------
'Constantes de atributos de archivos
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
'Otras constantes
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
'UDT
'------------------------------------------------------------------------------
'Estructura para las fechas de los archivos
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
'Estructura necesaria para la información de archivos
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Type T_Tag_Mp3
Header As String * 3
SongTitle As String * 30
Artist As String * 30
Album As String * 30
Year As String * 4
Comment As String * 30
Genre As Byte
End Type
Sub Busca_Archivos()
Dim Path As String
Dim Pattern As String
Dim FileSize As Currency
Dim Count_Archivos As Long
Dim Count_Dir As Long
ActiveWorkbook.Sheets("Leer").Activate
'Path y archivos a buscar
Path = ActiveSheet.Cells(1, 1).Value
Pattern = ActiveSheet.Cells(1, 2).Value
j = 2
'Llamamos a la función para buscar y que nos retorne algunos datos
FileSize = Encuentra_Archivos_API(Path, Pattern, Count_Archivos, Count_Dir)
'Mostramos los resultados
'Cantidad de archivos encontrados
MsgBox Count_Archivos & " Archivos encontrados en " & Count_Dir & " Directorios", 64
'Tamaño Total en Bytes de los archivos encontrados
MsgBox "Tamaño total de los archivos: " & Path & " = " & _
Format(FileSize, "#,###,###,##0") & " Bytes", 64
End Sub
Private Function Encuentra_Archivos_API(Path As String, SearchStr As String, _
FileCount As Long, DirCount As Long)
On Error GoTo EH
Dim FileName As String
Dim DirName As String
Dim dirNames() As String
Dim nDir As Long
Dim i, Archivo As Long
Dim hSearch As Long
Dim WFD As WIN32_FIND_DATA
Dim Cont As Long
Dim ar As String
Dim Ext As String
Dim Un_Tag As T_Tag_Mp3
If Right(Path, 1) <> "\" Then Path = Path & "\"
' Buscamos por mas directorios
nDir = 0
ReDim dirNames(nDir)
Cont = True
hSearch = FindFirstFile(Path & "*", WFD)
If hSearch <> INVALID_HANDLE_VALUE Then
Do While Cont
DirName = Eliminar_Nulos(WFD.cFileName)
' Ignora estos directorios
If (DirName <> ".") And (DirName <> "..") Then
' revisa el directrio
If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
dirNames(nDir) = DirName
DirCount = DirCount + 1
nDir = nDir + 1
ReDim Preserve dirNames(nDir)
End If
End If
Cont = FindNextFile(hSearch, WFD) 'Get next subdirectory.
Loop
Cont = FindClose(hSearch)
End If
hSearch = FindFirstFile(Path & SearchStr, WFD)
Cont = True
If hSearch <> INVALID_HANDLE_VALUE Then
While Cont
FileName = Eliminar_Nulos(WFD.cFileName)
If (FileName <> ".") And (FileName <> "..") Then
Encuentra_Archivos_API = Encuentra_Archivos_API + (WFD.nFileSizeHigh * MAXDWORD) + WFD.nFileSizeLow
FileCount = FileCount + 1
ActiveWorkbook.Sheets("Leer").Activate
j = j + 1
If j > 64999 Then
MsgBox "Existen demasiados archivos por favor seleccione una ruta mas corta", vbOKOnly + vbCritical, _
"ERROR"
End
End If
ActiveSheet.Cells(j, 1).Value = Path
ActiveSheet.Cells(j, 2).Value = FileName
Ext = Right(FileName, 4)
If Left(Ext, 1) = "." Then
ActiveSheet.Cells(j, 3).Value = Ext
End If
If Ext = ".mp3" Or Ext = ".wma" Then
ar = Path & FileName
Archivo = FreeFile
Open ar For Binary Access Read As Archivo
Get Archivo, LOF(1) - 127, Un_Tag
Close Archivo
ActiveSheet.Cells(j, 4).Value = Eliminar_Nulos(Un_Tag.Album)
ActiveSheet.Cells(j, 5).Value = Eliminar_Nulos(Un_Tag.Artist)
ActiveSheet.Cells(j, 6).Value = Eliminar_Nulos(Un_Tag.Comment)
ActiveSheet.Cells(j, 7).Value = Eliminar_Nulos(Un_Tag.Genre)
ActiveSheet.Cells(j, 8).Value = Eliminar_Nulos(Un_Tag.Header)
ActiveSheet.Cells(j, 9).Value = Eliminar_Nulos(Un_Tag.SongTitle)
ActiveSheet.Cells(j, 10).Value = Eliminar_Nulos(Un_Tag.Year)
End If
End If
Cont = FindNextFile(hSearch, WFD)
Wend
Cont = FindClose(hSearch)
End If
' Si estos son Sub Directorios......
If nDir > 0 Then
For i = 0 To nDir - 1
Encuentra_Archivos_API = Encuentra_Archivos_API + Encuentra_Archivos_API(Path & dirNames(i) & "\", _
SearchStr, FileCount, DirCount)
Next i
End If
Exit Function
EH:
Select Case Err.Number
Case 1004:
Resume Next
Case 63
Resume Next
Case Else:
MsgBox Err.Number & "-" & Err.Description, vbOKOnly + vbCritical
Resume
End Select
End Function
'Esta función es para formatear los nombres de archivos y directorios. Elimina los CHR(0)
'------------------------------------------------------------------------
Function Eliminar_Nulos(ByVal OriginalStr As String) As String
If (InStr(OriginalStr, Chr(0)) > 0) Then
OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
End If
Eliminar_Nulos = OriginalStr
End Function
- Compartir respuesta
- Anónimo
ahora mismo