Hola a todos!.
En esta web tengo varios post dedicados a listar los archivos de una carpeta y sus subcarpetas en concreto estos:
LISTAR TODOS LOS ARCHIVOS DE UNA CARPETA Y SUS SUBCARPETAS CON VBA
LISTAR LAS PROPIEDADES DE TODOS LOS ARCHIVOS DE UNA CARPETA Y SUBCARPETAS
y estos otros para listar los archivos que hayamos seleccionado y mostrar sus propiedades:
LISTAR TODOS LOS ARCHIVOS SELECCIONADOS
MOSTRAR PROPIEDADES DE ARCHIVOS SELECCIONADOS
Pues bien, hace unos días me enviaron la siguiente consulta:
«Hola Segu, gran trabajo y no sólo inicial, sino además contestando y mejorandolo con todas las preguntas.
Yo te quisiera hacer otra: Dentro de las propiedades de ficheros TIFF, jpg y pdf también tenemos las propiedades de Resolución Horizontal y Resolución Vertical (son propiedades como las de fecha de última modificación o tamaño) ¿Como se podrían extraer?.
Muchas gracias de antemano.»
La respuesta es que sí es posible, pero no podremos realizarlo con el objeto FileSystemObject (FSO) que utilizamos en los códigos anteriores, aunque sí vamos a aprovecharlo en parte de la macro donde utilizamos los métodos GetFolder y GetSubfolder que son necesarios para recorrer las carpetas y subcarpetas que hayamos seleccionado.
Para poder obtener la resolución horizontal y vertical (y muchas otras propiedades), debemos utilizar el objeto Shell necesario para interactuar con la librería Shell32.dll. Con este objeto vamos a poder extraer multitud de propiedades. Para que os hagáis una idea, hasta 349 propiedades aproximadamente pueden ser extraídas (según tipo de archivo), y entre ellas, la resolución.
En el código que os mostraré vamos a utilizar referencias tempranas (dado que es un poco más rápido que hacerlo con referencias tardías). Para ello es necesario que estén seleccionadas las siguiente referencias (en este archivo ya os las he seleccionado):
- Microsoft Shell Controls And Automation
- Microsoft Scripting Runtime
En caso de que no queráis depender de la biblioteca de referencias, solo tenéis que sustituir en el código:
Set sFSO = New FileSystemObject por esto Set sFSO = CreateObject("Scripting.FileSystemObject")
y Set objShell = New Shell por esto Set objShell = CreateObject("shell.application")
Veamos el ejemplo que nos ocupa. Imaginad estas imágenes y que necesitamos obtener y listar el dato de su resolución:
Para hacerlo vamos a utilizar la siguiente macro, donde el procedimiento Sub() ya lo conocéis de las funciones de los post anteriores, (aunque aquí estoy declarando FSO con referencia temprana). En cuanto a la función, es ahí donde programamos el objeto Shell y en este ejemplo únicamente voy a extraer el nombre, tamaño y las resoluciones (vertical y horizontal):
Option Explicit
Sub LISTAR_ARCHIVOS()
'Declaramos variables
Dim sFSO As Object, directorio As String
Dim dir_archivo As Variant
Call limpiar
'Abrimos ventana de diálogo para seleccionar carpeta
Set dir_archivo = Application.FileDialog(msoFileDialogFolderPicker)
dir_archivo.Show
'Si no seleccionamos nada salimos del proceso
If dir_archivo.SelectedItems.Count = 0 Then
Exit Sub
End If
'Capturamos el directorio del archivo seleccionado
directorio = dir_archivo.SelectedItems(1)
'Creamos objeto y ejecutamos función Carpeta
Set sFSO = New FileSystemObject
CARPETA sFSO.GetFolder(directorio)
End Sub
Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim j As Long, d As Long, n As Variant
Dim Subcarpeta As Object, objCarpeta As Object, objShell As Object
Dim item As Object
With Sheets("Hoja2")
'Iniciamos loop, que recorre las carpetas
For Each Subcarpeta In nCarpeta.SubFolders
CARPETA Subcarpeta
Next
'Creamos objeto Shell
n = nCarpeta
Set objShell = New Shell
'creamos carpeta con la función namespace. N debe ser variant
Set objCarpeta = objShell.Namespace(n)
'Creamos variable como contador
j = Application.CountA(.Range("A:A")) + 1
'Por cada ítem o archivo en la carpeta, obtenemos: Nombre (0), tamaño (1)
'Resolución horizontal (175), Resolución Vertical (177)
For Each item In objCarpeta.Items
.Cells(j, 1).Select
.Hyperlinks.Add Anchor:=Selection, Address:=item.Path, TextToDisplay:=item.name
'NOMBRE
.Cells(j, 1) = objCarpeta.GetDetailsOf(item, 0)
'TAMAÑO
.Cells(j, 2) = objCarpeta.GetDetailsOf(item, 1)
'RESOLUCION HORIZONTAL
.Cells(j, 3) = objCarpeta.GetDetailsOf(item, 175)
'RESOLUCION VERTICAL
.Cells(j, 4) = objCarpeta.GetDetailsOf(item, 177)
j = j + 1
Next item
End With
End Function
El resultado es este:
Como podéis observar, obtenemos los datos que necesitamos, en este caso la resolución es la misma en todos los casos.
Y con esto ya estaría resuelta la consulta que me han realizado. Pero como me ha parecido interesante el poder programar este objeto, he implementado otro código que genera hasta las 350 propiedades, las nombra y extrae el dato de cada una de ellas por cada archivo en la carpeta.
El procedimiento Sub no lo voy a pegar otra vez, dado que es el mismo. Pero la función cambia de manera sustancial. Ojo con esta macro, si seleccionáis una carpeta con muchos archivos y teniendo en cuenta que por cada uno extrae 350 elementos es probable que al equipo le cueste un poco. Ese es el motivo de haber dejado el primer ejemplo con los cuatro elementos para que podéis extraer solo lo que necesitéis mucho más rápido.
Function CARPETA(ByVal nCarpeta)
'Declaramos variables
Dim j As Long, d As Long, n As Variant
Dim Subcarpeta As Object, objShell As Object, objCarpeta As Object
Dim item As Object, name As Variant, i As Long
With Sheets("Hoja1")
'Iniciamos loop, que recorre las carpetas
For Each Subcarpeta In nCarpeta.SubFolders
CARPETA Subcarpeta
Next
'Creamos objeto Shell
n = nCarpeta
Set objShell = New Shell
'creamos carpeta con la funcion namespace
Set objCarpeta = objShell.Namespace(n)
'Obtenemos encabezados automáticamente con el método GetdetailsOf
'Que mostrará el nombre de cada valor
For i = 0 To 350
.Cells(1, i + 1) = i & "-" & objCarpeta.GetDetailsOf(name, i)
Next i
'Creamos variable como contador
j = Application.CountA(.Range("A:A")) + 1
'Por cada ítem o archivo en la carpeta, obtenemos cada uno de los elementos
'en este caso 350 donde el 1, es el nombre, el dos el tamaño, etc (en la vble "d")
For Each item In objCarpeta.Items
For d = 0 To 350
.Cells(j, 1).Select
.Hyperlinks.Add Anchor:=Selection, Address:=item.Path, TextToDisplay:=item.name
.Cells(j, d + 1) = objCarpeta.GetDetailsOf(item, d)
Next d
j = j + 1
Next item
End With
End Function
Y este es el mismo resultado con las imágenes anteriores:
No puedo mostrar todas las propiedades hasta las 350, pero como véis podemos extraer mucha información.
Y esto es todo!, espero que os sea de utilidad!!.
Normalmente os dejo el archivo en wordpress, pero esta vez tengo que alojarlo en Drive, el motivo es el de siempre, si el archivo es xlsm no puedo subirlo a mi web (políticas de WordPress.com).
Descarga el archivo de ejemplo pulsando en: LISTAR LAS PROPIEDADES DE TODOS LOS ARCHIVOS DE UNA CARPETA Y SUBCARPETAS CON EL OBJETO SHELL
¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.
¡¡Muchas gracias!!
Mediante la suscripción al blog, la realización comentarios o el uso del formulario de contacto estás dando tu consentimiento expreso al tratamiento de los datos personales proporcionados según lo dispuesto en la ley vigente (LOPD). Tienes más información al respecto en esta página del blog: Política de Privacidad y Cookies
Me gusta esto:
Me gusta Cargando...
EXCEL SIGNUM 