Extraer metadatos de archivos y colocarlos en excel con VBA
Debo indexar imágenes y las quiero etiquetar con el explorador de archivos
Lo consigo de esa forma.
Sub propiedades()
Dim arrHeaders(34)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("\\servidor\Imagenes\")
For i = 0 To 33
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
Next
For Each strFileName In objFolder.Items
For i = 0 To 33
Debug.Print i & vbTab & arrHeaders(i) & ": " & objFolder.GetDetailsOf(strFileName, i)
Next
Next
End Sub
La consulta es: si me puede ayudar a que lo hiciera recorriendo los existentes subdirectorios y poniendo los datos sobre una hoja excel con el nombre del fichero en las filas y sus propiedades en columnas. ( Separando las etiquetas que en origen están con ; diferentes columnas)
El objetivo es poder encontrar luego las fotos con un filtro avanzado por diferentes textos de etiquetas.
1 respuesta
Te anexo la macro. Cuando ejecutes la macro selecciona la carpeta inicial, la macro obtendrá los archivos de la carpeta inicial y también los archivos de cada subcarpeta contenida dentro la carpeta inicial.
Copia la macro en un módulo, observa que la primera línea de toda la macro debe ser:
Dim rutas As New Collection
Dim rutas As New Collection
'
Sub Listar_Archivos()
'Por.Dante Amor
'Listar archivos de carpeta y subcarpetas con sus propiedades
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ruta = "C:\trabajo"
ext = "*"
ActiveSheet.Rows("2:" & Rows.Count).Clear
Dim arrHeaders(34)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(ruta)
For i = 0 To 33
arrHeaders(i) = objFolder.GetDetailsOf(objFolder.Items, i)
Cells(1, i + 1).Value = arrHeaders(i)
Next
'
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
carpeta = .SelectedItems(1)
End With
'
If carpeta = "" Then Exit Sub
'
pPath = carpeta & "\"
rutas.Add carpeta
Call agregadir(pPath)
'
For Each sd In rutas
Call Propiedades(sd)
Next
'
Set rutas = Nothing
Application.ScreenUpdating = True
MsgBox "Fin, listar archivos", vbInformation, "ARCHIVOS"
End Sub
'
Sub agregadir(lpath) 'Agrega directorios
'Por.Dante Amor
Dim subdir As New Collection
If Right(lpath, 1) <> "\" Then lpath = lpath & "\"
DirFile = Dir(lpath & "*", vbDirectory)
Do While DirFile <> "" 'Agrega subdirectorios a collection
If DirFile <> "." And DirFile <> ".." Then _
If ((GetAttr(lpath & DirFile) And vbDirectory) = 16) Then _
subdir.Add lpath & DirFile
DirFile = Dir
Loop
For Each sd In subdir
rutas.Add sd
Call agregadir(sd)
Next
End Sub
'
Sub Propiedades(subdir)
'Act Por Dante Amor
'
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(subdir)
fila = Range("A" & Rows.Count).End(xlUp).Row + 1
For Each strFileName In objFolder.Items
For i = 0 To 33
'Debug.Print i & vbTab & arrHeaders(i) & ": " & objFolder.GetDetailsOf(strFileName, i)
Cells(fila, i + 1).Value = objFolder.GetDetailsOf(strFileName, i)
Cells(fila, 35).Value = subdir
Next
fila = fila + 1
Next
End Sub
Estimado Dante, es una solución precisa y elegante, funciona a la perfección como siempre.
Mil gracias.
Veo que realiza listado además de los ficheros de las carpetas y que no discrimina las imágenes.
En la 9ª línea veo la siguiente instrucción :
ext = "*"
Es posible que haya faltado incluir algo para poder filtrar la extensión?
Por otra parte podríamos usar un método similar al siguiente, ¿insertado en el bucle para convertir la ruta en hyperlink?
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Range(" .......
Gracias de nuevo
Home
Con mucho gusto te ayudo con todas tus peticiones.
Valora esta respuesta, al final de mi respuesta hay un botón para valorar: "Votar" y "Excelente".
Crea una nueva pregunta en el tema de microsoft Excel. Ahí me describes con detalle lo que necesitas.
Sal u dos
