jueves, 12 de mayo de 2016

VBA: El método Shapes.AddPicture para incorporar imágenes en Excel.

Con frecuencia se me ha planteado, al respecto de este post (ver), cuál era la forma de insertar imágenes en Excel de manera automática, desde una ruta concreta, pero rompiendo cualquier vínculo con el fichero origen de la imagen.
[...] Mi problema es el mismo que exponían mis compañeros en los comienzos de este foro (hace mil años): necesitaría que las imágenes estuvieran incrustadas y no vinculadas [...]


El objetivo es claro, insertar imágenes desde una ruta, pero perder cualquier vínculo existente para evitar que si el fichero de la imagen desaparece, nuestro Excel pierda la imagen:

VBA: El método .AddPicture para incorporar imágenes en Excel.



Fijémonos en el mensaje del cuadro de imagen: No se puede mostrar la imagen vinculada. Puede que se haya movido, cambiado de nombre o eliminado el archivo. Compruebe que el vínculo señala al archivo y ubicación correcta.

Muy aclaratorio mensaje, y muy real, ya que es muy frecuente que ocurran estos casos al trabajar en Red y compartir ficheros...


La solución es emplear el método Shapes.AddPicture, a partir del cual crearemos una imagen a partir de un archivo existente, en una ruta concreta, obteniendo un objeto Shape que muestre la imagen...
La ventaja de este método es que podemos configurar si deseamos la imagen con o SIN vínculo!!

La sintaxis del método:
Shapes.AddPicture(Filename,LinkToFile, SaveWithDocument, Left, Top, Width, Height)
y los parámetros a definir podrían ser:
Filename
Requiere una cadena tipo String, con la ruta del fichero a importar, esto es, el fichero/imagen a partir de la cual se crearña el objeto Shape.

LinkToFile
Requiere una contante tipo 'MsoTriState'. Controla cómo será el vínculo, o si queremos exista éste.
Las constante puede ser:
1-msoFalse (hará independiente la imagen importada)
2-msoTrue (se creará un vínculo hacia la ruta o ubicación de la imagen indicada)

SaveWithDocument
Requiere una contante tipo 'MsoTriState', y controla la acción para conservar o guardar la imagen dentro del libro.

Left, Top, Width, Height
estas son propiedades de ubicación en la hoja de cálculo y dimensiones (Alto y Ancho), medidos en Points!!.


Para resolver nuestra cuestión en particular, insertamos el siguiente código dentro de un módulo estándar del explorador de proyectos del Editor de VB.:

Sub FicherosCarpeta()
'www.excelforo.com
'Añadir Imagenes a Excel

'Crea una Imagen desde un fichero y
'devuelve un objeto NO vinculado a el fichero origen

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 E:\excelforo\Fotos\
Ruta = "E:\excelforo\Fotos\"
'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("Hoja2").Range("A2:A15")
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)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'VARIANTE PARA AÑADIR IMAGEN NO VINCULADA AL FICHERO Y RUTA!!
Set Fotos = ActiveSheet.Shapes.AddPicture(Filename:=Ruta & celda.Value, _
linktofile:=msoFalse, savewithdocument:=msoCTrue, _
Left:=0, Top:=0, Width:=-1, Height:=-1)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'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



La parte diferente del código responde por tanto a la línea:

Set Fotos = ActiveSheet.Shapes.AddPicture(Filename:=Ruta & celda.Value, _
            linktofile:=msoFalse, savewithdocument:=msoCTrue, _
            Left:=0, Top:=0, Width:=-1, Height:=-1)
       
 


donde vemos configurados los tres parámetros importantes:
Filename:=Ruta & celda.Value: donde indicamos la ubicación de la imagen a importar.
linktofile:=msoFalse: donde decimos que NO deseamos exista un vínculo con la ubicación del fichero
y
savewithdocument:=msoCTrue: donde controlamos y exigimos la imagen quede guardad con el Libro de trabajo.

En definitiva conseguimos la acción buscada, hemos importado la imagen sin vínculo!!; y por tanto no se perderá aunque la ubicación, ruta o fichero desaparezca o cambie...

VBA: El método .AddPicture para incorporar imágenes en Excel.

18 comentarios:

  1. Hola Ismael, excelente artículo y muy útil para quienes no desean vincular la imagen. El problema que estoy teniendo es que la imagen se termina quedando en la celda A1. A continuación te paso el código que estoy desarrollando para ver si me puedes orientar dónde está el error. Desde ya muchas gracias.

    Norberto

    Sub Insertar1()

    Dim FileNames As Variant
    Dim Foto As Object

    FileNames = Application.GetOpenFilename(, , , , True)

    Counter = 1

    Range("B2").Select

    While Counter <= UBound(FileNames)
    Set Foto = ActiveSheet.Shapes.AddPicture(FileNames Counter), False, True, 0, 0, -1, -1)
    With Foto
    .Name = "foto_" & Counter
    .Top = ActiveCell.Top
    .Height = 50
    ActiveCell.EntireRow.RowHeight = .Height + 2

    If ActiveCell.ColumnWidth < .Width * 0.1891891891892 Then
    ActiveCell.ColumnWidth = .Width * 0.1891891891892
    End If

    End With
    ActiveCell.Offset(0, 1).Select
    Counter = Counter + 1
    Wend

    End Sub

    ResponderEliminar
  2. Perdón donde dice FileNames Counter) debe decir FileNames(Counter)

    ResponderEliminar
    Respuestas
    1. Hola Norberto,
      lo primero es que tienes un bucle While...Wend que parece nunca podrá aplicar, ya que con el método GetOpenFilename seleccionarás solo un fichero (así el contador counter no subirá nunca).
      Por tanto siempre trabajarás sobre la celda B2 seleccionada, insertando la imagen en esa celda, y en apariencia, al no tener asignada la propiedad .Left de la imagen, sobre la columna A.

      No sé exactamente qué necesitas hacer, pero con ese código sólo insertas una imagen en la celda B2...

      Saludos

      Eliminar
    2. Hola Ismael,
      Gracias por tu pronta respuesta. La idea es seleccionar una cantidad determinada de imágenes (es lo que hago con el método GetOpenFilname, en Counter voy contando las imagenes que selecciono) y luego colocar las mismas primero en la celda B2, y las consecutivas en las celdas contiguas a la derecha.
      El bucle lo utilizo para realizar la misma acción (o sea colocar la imagen) para cada imagen seleccionada.
      Slds

      Eliminar
    3. Hola Ismael,
      Tenías razón faltaba asignar la propiedad .Left
      Acabo de probar asignando .Left = ActiveCell.Left y ahora funciona a la perfección. El problema surge cuando uno se "enfrasca" desde un punto de vista y pierde el contexto.
      Nuevamente muchísimas gracias por tu ayuda.
      Slds

      Eliminar
    4. ;-)
      nos pasa a todos... son muchos detalles a tener en cuenta.
      Un saludo

      Eliminar
  3. Excelente post, Ismael!

    Soy una verdadera fan de tu blog. Pensaba que sabía algo de Excel pero cada día me doy cuenta que menos. He rescatado este post tuyo del 2016 dado que en estoy involucrada en un proyecto en el que tengo que colocar más de 300 imagenes en cada fila.

    Yo he estado usando el siguiente Macro pero las imágenes simplemente no se guardan con el documento, sólo se vinculan :-(

    Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate
    Folderpath = "RUTA DE LA CARPETA"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
    strCompFilePath = Folderpath & "\" & Trim(fls.Name)
    If strCompFilePath <> "" Then
    If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
    Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
    Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
    counter = counter + 1
    Sheets("Object").Range("A" & counter).Value = fls.Name
    Sheets("Object").Range("B" & counter).ColumnWidth = 25
    Sheets("Object").Range("B" & counter).RowHeight = 100
    Sheets("Object").Range("B" & counter).Activate
    Call insert(strCompFilePath, counter)
    Sheets("Object").Activate
    End If
    End If
    Next
    mainWorkBook.Save
    End Sub

    Function insert(PicPath, counter)
    'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
    With .ShapeRange
    .LockAspectRatio = msoTrue
    .Width = 24
    .Height = 99
    End With
    .Left = ActiveSheet.Range("B" & counter).Left
    .Top = ActiveSheet.Range("B" & counter).Top
    .Placement = 1
    .PrintObject = True
    End With
    End Function


    He intentado integrar ActiveSheet.Shapes.AddPicture pero no hay manera. Con el macro actual me coloca todas las imagenes tal como quiero pero no las puedo guardar en un documento.

    Se te ocurre como podría integrar ActiveSheet.Shapes.AddPicture aquí?

    Un fortísimo abrazo

    Marta G.

    ResponderEliminar
    Respuestas
    1. Muchas gracias Marta,
      a mi mismo me pasa cada día (soy más consciente de lo poco que sé en Excel)... así que ánimo!
      En cuanto a tu cuestión... yo probaría convirtiendo tu función en procedimiento Sub:

      Sub insert(PicPath, counter)

      Set Fotos = ActiveSheet.Shapes.AddPicture(Filename:=PicPath, _
      linktofile:=msoFalse, savewithdocument:=msoCTrue)

      With .ShapeRange
      .LockAspectRatio = msoTrue
      .Width = 24
      .Height = 99
      End With
      .Left = ActiveSheet.Range("B" & counter).Left
      .Top = ActiveSheet.Range("B" & counter).Top
      .Placement = 1
      .PrintObject = True
      End With
      End Sub


      El resto creo podría quedar como está...
      Saludos!

      Eliminar
  4. Muchísimas gracias por tu respuesta, Ismael!
    Te lo agradezco muchísimo.

    Lo he editado para convertirlo en un procedimiento sub dejando el procedimiento principal igual, como indicaste, pero sigue dando error.

    Te copio una impresión de pantalla:
    http://i.imgur.com/d61cU9F.jpg

    Me dice "Referencia no válida o sin calificar"

    Qué puede ser?

    Un abrazo!!

    ResponderEliminar
    Respuestas
    1. claro,tienes que ajustar tus sentencias With.. end with a la nueva situación, así como el resto de configuraciones que tenías de posición (top, left) y dimensiones (witdh y height)...

      Saludos

      Eliminar
  5. Muchas gracias, Ismael!

    Eso he hecho pero no consigo que funcione. No soy muy ducha en VBA, la verdad. Algo estoy haciendo mal. Como verás más abajo he definido el .Width y .height un pixel más pequeño que el tamaño de la celda para evitar distorsionar las imagenes cuando edite el tamaño de las filas/columnas, de lo contrario se anclan a los extremos de las celdas.

    Pero... sigo sin conseguir que funcione. Estoy convencido que te lloverán dudas cada día pero no consigo la solución por mi misma y son cientos de imágenes cada dos por tres, quiero intentar automatizarlo. Puedo perder horas y horas a la semana sin hacer nada realmente productivo. He revisado tu post de "VBA: Una macro en Excel para insertar imágenes" y todos sus respectivos comentarios. Nadie consigue tampoco dar una respuesta concluyente.

    Si tienes un huequito para revisarlo, para llegar a una solución concreta me ayudaría muchísisisimo. No te lo puedes ni imaginar!

    Un fuerte abrazo!

    --------------------------------------------

    Sub AddOlEObject()

    Dim mainWorkBook As Workbook

    Set mainWorkBook = ActiveWorkbook
    Sheets("Object").Activate
    Folderpath = "C:\Users\RUTA"
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count
    Set listfiles = fso.GetFolder(Folderpath).Files
    For Each fls In listfiles
    strCompFilePath = Folderpath & "\" & Trim(fls.Name)
    If strCompFilePath <> "" Then
    If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
    Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
    Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
    counter = counter + 1
    Sheets("Object").Range("A" & counter).Value = fls.Name
    Sheets("Object").Range("B" & counter).ColumnWidth = 25
    Sheets("Object").Range("B" & counter).RowHeight = 100
    Sheets("Object").Range("B" & counter).Activate
    Call insert(strCompFilePath, counter)
    Sheets("Object").Activate
    End If
    End If
    Next
    mainWorkBook.Save
    End Sub

    '--------------------------

    Sub insert(PicPath, counter)

    Set Fotos = ActiveSheet.Shapes.AddPicture(Filename:=PicPath, _
    linktofile:=msoFalse, savewithdocument:=msoCTrue)

    ' no sé si aquí cogerá bien el path de cada archivo en cuestión. En el sub superior ya he definido la ubicación de la carpeta y los formatos. Debería poner strCompFilePath como Filename?

    With .ShapeRange
    .LockAspectRatio = msoTrue 'evito distorsionar la imagen
    .Width = 24
    .Height = 99
    End With
    .Left = ActiveSheet.Range("B" & counter).Left
    .Top = ActiveSheet.Range("B" & counter).Top
    .Placement = 1
    .PrintObject = True
    End With
    End Sub

    ResponderEliminar
    Respuestas
    1. Lo miraré en cuanto me sea posible...
      mientras emplea el código del post que es 100% funcional, y hace precisamente lo que tu quieres
      Saludos

      Eliminar
  6. Hola Ismael,

    He intentado usar tu código pero tampoco funciona. Te adjunto un vídeo para que veas, paso a paso, el proceso. He usado tu código tal cual, cambiando la ruta, pero no importa las imágenes de la carpeta (sólo el literal del nombre del archivo en la primera columna). Son todos archivos en JPG.

    Video: https://www.youtube.com/watch?v=w6jn8tJr4I0

    Es probable que no sea la única con este problema o, posiblemente, esté cometiendo un error de novata. ¿Qué puede ser?

    Un saludo!

    ResponderEliminar
    Respuestas
    1. Hola Marta,
      El código del post es correcto, aunque no se distingue bien tu video, parece que tu ruta tiene esta forma:
      C:\MARCAS_FOTO
      y debería ser (revisa el código del post)
      C:\MARCAS_FOTO\
      Slds

      Eliminar
  7. Muchas gracias Ismael! vaya error tan tonto! Un abrazo!

    ResponderEliminar