VBA: Una macro en Excel para listar las propiedades de un archivo.

En un articulo anterior mostré la forma en que podíamos listar los archivos contenidos en una carpeta de nuestro PC. Hoy, en respuesta a un lector que necesitaba además del nombre otras serie de datos de esos ficheros, explicaré qué código es necesario para obtener ciertas propiedades o atributos de los ficheros / archivos contenidos en una carpeta.
En particulas obtendremos en nuestra Hoja de excel, las propiedades:
Nombre = .Name
Fecha creación = .DateCreated
Fecha último acceso = .DateLastAccessed
Fecha última modificación = .DateLastModified
Tipo archivo = .Type
Tamaño en bytes = .Size
Ruta corta utilizada por los programas que necesitan necesitan la convención de nomenclatura 8+3 = .shortpath
Nombre corto utilizado por los programas que necesitan la convención de nomenclatura 8+3 = .shortname
Devuelve los atributos de archivos o carpetas. Lectura o escritura, o sólo lectura, dependiendo del valor atributo = .Attributes
Ruta completa = .Path
Insertaremos en un módulo del Explorador de proyectos del Editor de VBA el siguiente código, formando nuestra macro de Excel:

Sub ListarPropiedadesFicherosCarpeta()
'www.excelforo.com
Dim Ruta As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creamos el objeto FileSystemObject que
'proporciona acceso al sistema de archivos de un equipo
Set fso = CreateObject("Scripting.FileSystemObject")
'Indicamos la ruta de donde vamos a obtener
'los ficheros, en este caso D:\BancoFotos
Ruta = "D:\BancoFotos\"
'definimos dos variables que necesitaremos,
'para recuperar el nombre de la carpeta, y los ficheros que haya dentro
Set Carpeta = fso.GetFolder(Ruta)
Set ficheros = Carpeta.Files
'damos un título en negrita para la celda A1
Range("A1").Value = "Ficheros de la carpeta " & Ruta
Range("B1").Value = "Fecha creación"
Range("C1").Value = "Fecha último acceso"
Range("D1").Value = "Fecha última modificación"
Range("E1").Value = "Tipo archivo"
Range("F1").Value = "Tamaño en bytes"
Range("G1").Value = "Ruta corta"
Range("H1").Value = "Nombre corto"
Range("I1").Value = "Atributo"
Range("J1").Value = "Ruta completa"
Range("A1:J1").Font.Bold = True

'escribimos los ficheros, a partir de A2
Range("A2").Select
For Each archivo In ficheros
    'escribimos el nombre del fichero
    ActiveCell = archivo.Name
    ActiveCell.Offset(0, 1) = archivo.DateCreated
    ActiveCell.Offset(0, 2) = archivo.DateLastAccessed
    ActiveCell.Offset(0, 3) = archivo.DateLastModified
    ActiveCell.Offset(0, 4) = archivo.Type
    ActiveCell.Offset(0, 5) = archivo.Size
    ActiveCell.Offset(0, 6) = archivo.shortpath
    ActiveCell.Offset(0, 7) = archivo.shortname
    ActiveCell.Offset(0, 8) = archivo.Attributes
    ActiveCell.Offset(0, 9) = archivo.Path
    
    'bajamos una fila
    ActiveCell.Offset(1, 0).Select
Next archivo
Range("A:J").EntireColumn.AutoFit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Limpiamos los objetos y variables definidas
Set fso = Nothing
Set Carpeta = Nothing
Set ficheros = Nothing

Application.ScreenUpdating = True
End Sub

Al ejecutar la macro en la hoja de Excel podemos ver el resultado:

haz click en la imagen

VBA: Una macro en Excel para insertar imágenes.

Finalizando con este post la serie de artículos sobre el tratamiento de imágenes, hoy explicaré como, mediante una macro de Excel podemos listar los ficheros contenidos en una Carpeta y en qué forma, aprovechando los nombres de esos ficheros (imágenes), los insertaremos en las celdas contigüas respectivas, adecuando el tamaño de la celda.
Es por tanto un resumen de las entradas anteriores, añadiendo a éstas la instrucción .Picture.Insert que habilita la inserción de imágenes si trabajamos con Excel 2007 o Excel 2010.
En el ejemplo sobre el que trabajo la ruta es fija, definida sobre una variable incluida en la macro de Excel, en particular: D:\BancoFotos\
Insertaremos en un módulo del Explorador de proyectos del Editor de VBA el siguiente código, formando nuestra macro de Excel:

Sub FicherosCarpeta()
'www.excelforo.com
Dim Ruta As String
Dim Fotos As Object
Dim rng As Range, celda As Range

'Saltamos posibles errores
On Error Resume Next
Application.ScreenUpdating = False
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim img As Shape
'si existe alguna foto, la borro:
On Error Resume Next
For Each img In ActiveSheet.Shapes
     If img.Type = 11 Then img.Delete
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Creamos el objeto FileSystemObject que
'proporciona acceso al sistema de archivos de un equipo
Set fso = CreateObject("Scripting.FileSystemObject")
'Indicamos la ruta de donde vamos a obtener
'los ficheros, en este caso D:\BancoFotos
Ruta = "D:\BancoFotos\"
'definimos dos variables que necesitaremos,
'para recuperar el nombre de la carpeta, y los ficheros que haya dentro
Set Carpeta = fso.GetFolder(Ruta)
Set ficheros = Carpeta.Files
'damos un título en negrita para la celda A1
With Range("A1")
    .Value = "Ficheros de la carpeta " & Ruta
    .Font.Bold = True
End With
'escribimos los ficheros, a partir de A2
Range("A2").Select
For Each archivo In ficheros
    'escribimos el nombre del fichero
    ActiveCell = archivo.Name
    'bajamos una fila
    ActiveCell.Offset(1, 0).Select
Next archivo
ActiveCell.EntireColumn.AutoFit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set rng = Worksheets("Hoja1").Range("A2:A5")
For Each celda In rng
If Len(Trim(celda)) > 0 Then
        'defino la celda equivalente de la columna A y la selecciono
        Set r1 = Cells(celda.Row, "B")
        r1.Select
        'se inserta la imagen de la ruta definida
        Set Fotos = ActiveSheet.Pictures.Insert(Ruta & celda.Value)
        'con la posición definida respecto a la celda de la columna B seleccionada
        With Fotos
            .Top = r1.Top
            .Width = .Width / 1.5
            .Height = .Height / 1.5
            .Left = r1.Left + (r1.Width - Fotos.Width) / 2
            .ShapeRange.LockAspectRatio = msoFalse
             r1.EntireRow.RowHeight = .Height
            .Placement = xlMoveAndSize
        End With
    r1.Select
End If
Next celda
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Limpiamos los objetos y variables definidas
Set fso = Nothing
Set Carpeta = Nothing
Set ficheros = Nothing
Set rng = Nothing
Set r1 = Nothing
Set Fotos = Nothing

Application.ScreenUpdating = True
End Sub

En esta entrada lo más importante, y novedoso respecto a las anteriores explicaciones, es la parte del código VBA donde se recorre el rango A2:A5 donde se insertaron los nombres de los ficheros de imagen, para ir incorporando en la celda contigüa (columna B) la imagen que le corresponda por nombre:
ActiveSheet.Pictures.Insert(Ruta & celda.Value)
Podemos ver en imágenes el antes y después de la ejecución de la macro 'FicherosCarpeta':

Si ejecutamos la macro asignada al botón Listar e Insertar imágenes obtendríamos:

Consiguiendo lo que pretendíamos, es decir listar el contenido de ficheros de una carpeta de nuestro equipo, e insertar a nuestra Hoja de cálculo de Excel las imágenes de esa carpeta.

VBA: Centrar una imagen en el interior de una celda de Excel.

Siguiendo con el tema de los últimos días, hoy veremos cómo podemos tratar una imagen(Picture), para mediante una macro de Excel, ajustarla lo máximo posible, en el interior de una celda.
En particular trabajaremos con las propiedades .Top, .Left, .Height y .Width
Supongamos tenemos ya una imagen en nuestra Hoja de Excel, y queremos moverla, adaptádola a otra celda, por ejemplo F5:

Insertaremos en un módulo del Explorador de proyectos del Editor de VBA el siguiente código, formando nuestra macro de Excel:

Sub CentrarImagen()
Dim Fotos As Object
Dim celda As Range

Set celda = Cells(5, "F")
Set Fotos = ActiveSheet.Shapes.Range(Array("1 Picture"))
'asignamos un Anco a la columna de la celda F5, proporcianada al ancho de la Imagen
celda.ColumnWidth = Fotos.Width / 10.67111364
With Fotos
    .Top = celda.Top
    'reducimos el alto y ancho de la foto
    .Width = .Width / 1.5
    .Height = .Height / 1.5
    'se centra horizontalmente en la celda indicada
    .Left = celda.Left + (celda.Width - Fotos.Width) / 2
    'damos altura a la fila igual al alto final de la imagen
    celda.EntireRow.RowHeight = .Height
End With

Set celda = Nothing
Set Fotos = Nothing

End Sub

Podemos ver el resultado, ampliado, de cómo queda situada la imagen dentro de la celda F5, tras ajustar Ancho, Alto (reducidos en un 33%) y centrarla horizontalmente respecto a la celda F5.

Como vemos, conseguimos adaptar el tamaño de celda al tamaño final de la imagen, de manera bastante ajustada.