Insertar imágenes en un catálogo con imagen por defecto

Hola:

Suponiendo que teneis un catálogo de artículos (O de cualquier otra cosa) y quereis que aparezca una imagen del artículo, colocar el nombre de la imagen con la extensión (.jpg, .gif, .bmp) en la columna A a partir de la celda A2.

Al ejecutar la macro se insertarán las imágenes en la propia columna A adaptándolas al tamaño de la celda.

Si no existiera la imagen, se inserta una imagen con el nombre "sin imagen"

Sub InsertarImágenes()

Dim MiPc As Object

Dim MiCarpetaDeImágenes As Variant

Dim MiImagen As Variant

Dim SinImagen As Variant


'------- Creamos variables de uso

Set MiPc = CreateObject("Scripting.FileSystemObject") 'Todos los archivos

MiCarpetaDeImágenes = ThisWorkbook.Path

SinImagen = MiCarpetaDeImágenes & "\sin imagen.jpg" '<=================


'------- Proceso de inserción de la imagen

Application.ScreenUpdating = False

Range("A2").Select

Do Until ActiveCell = ""


   '-------- Eliminamos imagen anterior si la hay

   On Error Resume Next

   ActiveSheet.Shapes("@@" & ActiveCell.Address(False, False)).Delete

   On Error GoTo 0


   '-------- Determinamos imagen a insertar

   MiImagen = MiCarpetaDeImágenes & "\" & ActiveCell

   If MiPc.FileExists(MiImagen) = False Then MiImagen = SinImagen


   '------- Insertamos la imagen y la ajustamos a la celda

   ActiveSheet.Pictures.Insert(MiImagen).Select

   With Selection.ShapeRange

     .Name = "@@" & ActiveCell.Address(False, False)

     .LockAspectRatio = False        'Permite modificar la imagen

     .Top = ActiveCell.Top - 1       'Distancia al borde superior

     .Left = ActiveCell.Left - 1     'Distancia al borde izquierdo

     .Height = ActiveCell.Height - 1 'Alto de la imagen

     .Width = ActiveCell.Width - 1   'Ancho de la imagen

   End With

   ActiveCell.Offset(1, 0).Select

Loop


End Sub


[/CODE]

Saludos