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.