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.

35 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
  8. Hola Ismael, tengo un codigo parecido; el codigo me inserta las imagenes en una hoja pero cuando paso a la otra , llega un momento que cuando aplica el comando para insertar imagenes , salta el bucle.

    ResponderEliminar
    Respuestas
    1. Hola!
      asegúrate que el proceso de selección de ruta y la celda destino es correcta en cuanto a hoja activa (Activesheet)...
      Es difícil darte una respuesta clara sin ver el código exacto

      Saludos

      Eliminar
  9. Buenas tardes Ismael. he estado siguiendo tu blog, es una maravilla. Mira, estoy enfrascado en una rutina similar a la tuya. La diferencia es que las imágenes van insertadas en celdas combinadas y lo he resuelto bien con ActiveCell.MergeArea. Sin embargo no logro hacer que cuando inserto la imagen, en la celda (tambien combinada) inferior aparezca el nombre del archivo. Debe ser con el Offset, pero no logro acomodarlo.

    La rutina es la siguiente:

    Option Explicit
    Sub InsertarImagen()

    Dim archivoimagen As String
    Dim Imagen As Shape
    Dim FolderInicio As String

    FolderInicio = ThisWorkbook.Path & "\FOTOS\" 'especifica la carpeta de FOTOS, debe existir de previo
    ChDrive Left(FolderInicio, 1)
    ChDir FolderInicio

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

    'abre el cuadro para escoger la imagen
    archivoimagen = Application.GetOpenFilename( _
    FileFilter:="Images (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
    FilterIndex:=1, _
    Title:="Insertar Imagen", _
    ButtonText:="Insertar", _
    MultiSelect:=False)
    If archivoimagen = "False" Then Exit Sub
    On Error Resume Next

    With ActiveCell.MergeArea
    ActiveSheet.Shapes.AddPicture _
    Filename:=archivoimagen, _
    linktofile:=msoFalse, _
    savewithdocument:=msoTrue, _
    Left:=.Left, _
    Top:=.Top, _
    Width:=.Width - 25.5, _
    Height:=.Height - 3
    End With
    End Sub

    Te agradezco tu amable ayuda.

    ResponderEliminar
    Respuestas
    1. Hola,
      lo primero sería conocer cuantas celdas están combinadas, donde se vaya a insertar la imagen... ya que en función a eso se podrá ubicar la posición real de la 'celda inferior' (que podría estar realmente en cualquier número de fila por debajo...)
      Así pues, la clave es contar el número de celdas 'reales' combinadas, para una vez sabido, aplicar efectivamente un OFFSET desde la celda activa que usas...
      Escribiré un post para explicar cómo contar celdas en una combinación..
      Saludos

      Eliminar
    2. Hola Ismael, muchas gracias por tu respuesta. Mi nombre es Jonathan por cierto (aparezco como Unknow). Lo resolví con la siguiente rutina.Te la dejo por si le sirve de ayuda a alguien.

      Lo de RangoPermitido fue una prueba que no sirvió, al final lo resolví con ScrollArea.

      Te agradezco tus consejos.

      Option Explicit
      Sub InsertarImagen()

      Dim Imagen As Shape 'define la variable Imagen como un Shape
      Dim FolderInicio As String 'define la variable FolderInicio como texto
      Dim celdas As Range 'define la variable celdas como rango de celdas
      Dim archivoimagen As Variant 'define la variable archivoimagen como variable
      Dim y As Integer
      Dim x As Integer
      'Dim RangoPermitido As Range

      Application.ScreenUpdating = False ' para hacer la rutina silenciosa

      Set celdas = ActiveCell.MergeArea 'las celdas seleccionadas serán las que se van a trabajar

      'RangoPermitido = Range("a9:ag1000")
      'If celdas.Address <> RangoPermitido Then
      ' MsgBox "Inserte la imagen en el área para tal fin", , "Zona no permitida"
      ' Exit Sub
      'Else

      FolderInicio = ActiveWorkbook.Path & "\FOTOS\" 'especifica la carpeta de FOTOS, debe existir de previo
      ChDrive Left(FolderInicio, 1)
      On Error GoTo noFolder
      ChDir FolderInicio
      noFolder:
      If Err.Number = 76 Then
      MsgBox "Verifique que existe la carpeta 'FOTOS' con las imágenes que desee insertar", , "No se encuentra la carpeta"
      Exit Sub
      End If

      If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

      'abre el cuadro para escoger la imagen
      archivoimagen = Application.GetOpenFilename( _
      FileFilter:="Images (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
      FilterIndex:=1, _
      Title:="Insertar Imagen", _
      ButtonText:="Insertar", _
      MultiSelect:=False)
      If archivoimagen = "Falso" Then
      Exit Sub 'cierra el cuadro de dialogo si no se selecciona
      Else
      archivoimagen = Mid(archivoimagen, InStrRev(archivoimagen, "\") + 1) 'devuelve el nombre del archivo escogido
      ActiveCell.Offset(1, 0).Value = archivoimagen ' inserta el nombre de la Shape en la celda inferior
      End If

      On Error Resume Next 'omitir errores

      'carga la Imagen seleccionada anteriormente en la memoria:
      Set Imagen = ActiveSheet.Shapes.AddPicture(filename:=archivoimagen, linktofile:=msoFalse, _
      savewithdocument:=msoTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)

      'Coloca la Imagen seleccionada de acuerdo a lo siguiente:
      With Imagen
      .ShapeRange.LockAspectRatio = msoTrue ' bloquea el aspecto para que no se distorcione
      .Top = celdas.Top 'coloca la Imagen en la celda seleccionada
      If .Height > celdas.Height Then .Height = celdas.Height - 3 'define la altura de la Imagen igual a la altura de la celda menos 3 pts.
      If .Width > celdas.Width Then .Width = celdas.Width - 3
      'End If
      'End If
      .Left = celdas.Left 'coloca la Imagen en la celda seleccionada, referencia de izquierda
      End With

      For Each Imagen In ActiveSheet.Shapes
      Range(Imagen.TopLeftCell.Address).Select
      y = Selection.Height - Imagen.Height
      x = Selection.Width - Imagen.Width
      Imagen.Top = Selection.Top + (y / 2)
      Imagen.Left = Selection.Left + (x / 2)
      Imagen.Placement = xlFreeFloating
      Next

      'esta macro elimina la extensión de archivo
      Rows("8:1000").Select
      Selection.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
      celdas.Select
      'End If

      Set Imagen = Nothing

      End Sub

      Eliminar
    3. Yo de nuevo. La variante que quisiera, es algo similar a tu rutina: insertar todas las imáganes de una carpeta pero en cierto orden. Mi Reporte Fotográfico consta de tres rangos de celdas combinadas (A9:K17, L9:V17 y W9:AG17) con ancho de columna = 2.5. Debajo de cada rango hay otro renglón donde va el nombre del archivo (A18:K18, L18:V18 y W18:AG18) respectivamente. Después se vuelve a repetir la secuencia hacia abajo, hasta completar 20 juegos, es decir, para insertar 60 fotos. Entonces la rutina sería de un folder definido, inserte tres imagenes una MergeArea, baje un Row e inserte los nombres, baje un Row y de nuevo inserte imágenes en el MergeArea y baje otro Row e inserte el nombre y repetir el ciclo hasta que se acaben las fotos, no necesariamente 60 fotos, pueden ser menos, pero no más.

      Te agradezco de nuevo tus consejos.

      Eliminar
    4. Gracias por el aporte Jonathan ;-)
      Como te decía escribiré un post para explicar una manera de conseguirlo
      Saludos cordiales

      Eliminar
    5. Saludos Ismael, no quisiera parecer atrevido y estoy seguro que pasas ocupado, pero apenas tengas un tiempito te agradecería tu muy amable ayuda con este tema, muchisimas gracias de antemano por tu amabilidad!

      Eliminar
    6. Hola,
      ya publiqué la forma en que determinar el número de celdas de alto y ancho de una celda combinada...
      http://excelforo.blogspot.com/2018/09/vba-ancho-y-alto-de-una-celda-combinada.html
      Eso te dará la clave para localizar la posición que necesitas

      Saludos

      Eliminar
    7. Muchas gracias Ismael, si vi tu post (reviso tu blog seguido), sin embargo lo que no he logrado, es como hacer el loop (o lo que sea), para que inserte tres imágenes en fila, y baje otra fila e inserte otras tres y baje sucesivamente hasta que se acaben las imágenes. Mira, el patrón es este: https://drive.google.com/file/d/1LkOqqH_SRhkUC40F8YDEg_Itxw45ijIG

      Eliminar
    8. Hola Jonathan,
      para dar saltos de ese estilo, por filas o columnas, se suele emplear un contador, dentro de un bucle, que determine cuándo saltar de fila.. de tal forma que cuando el contador llegara a 3 (en tu caso) se ponga cero y salte de fila el número de celdas deseado

      Saludos

      Eliminar
    9. Gracias Ismael, te contaré cuando lo pueda resolver. Te agradezco tu ayuda!

      Eliminar
  10. Hola Ismael: tengo un programa en excel de historia clínica para el servicio de emergencias del Hospital Local de Ibarra que está relacionado con el servicio de imágenes Rayos-X. He probado la macro FicherosCarpeta de mayo 2012 para ver si transfiero las imágenes .jpg de rayos X desde BancoFotos a las celdas de emergencia, pero no funciona.
    El procedimiento requerido es el siguiente:
    1. Emergencia envía una o varias solicitudes de rayos X, en diferentes momentos de la atención al paciente. Macro 1, mediante Outlook
    2. Radiología genera una o varias imágenes de los estudios solicitados, de acuerdo a la llegada de solicitudes del mismo paciente.
    3. Las fotos de las imágenes y su descripción se almacenan en una galería de imágenes (puede ser Benchmark Email), con la dirección web de la imagen .jpg.
    4. Emergencia recibe en su email (Windows Live Mail que guarde feeds en la nube) los mensajes de las actualizaciones de las nuevas imágenes mediante un administrador de Email (puede ser Widget Microsiervos RSS) y los registra en celdas seleccionadas del formulario Excel del paciente (de acuerdo a la solicitud y a la llegada del informe)

    Actualmente probamos un folder (BancoFotos) en el que se almacenan manualmente (guardar como) las direcciones de las fotos archivo .jpg y luego asignamos las imágenes a cada celda definida. Macro 4, mediante hipervínculo.
    Solicito tu concepto técnico sobre el caso y ver si puedo, por lo menos, hacer que funcione la macro inicial de tu blog.
    Saludos y agradecimiento por tu atención.

    ResponderEliminar
  11. Hola Ismael: ya funcionó la macro FicherosCarpeta. Era cuestión de actualizar la ruta. Aún así, se requiere la actualización de imágenes a medida que se envían los informes de rayos x

    ResponderEliminar
    Respuestas
    1. ;-)
      a qué te refieres con actualizar las imágenes??

      Saludos cordiales

      Eliminar
  12. Alguienpodria ayudarme para adecuar este codigo a manera de quitar el vinculo y dejarlas como imagenes guardadas en el archivo


    Sub Imágenes()
    Dim RutaActual As String
    Dim RangoImagen As Range
    Dim shp As Object
    On Error Resume Next
    For Each shp In ActiveSheet.Shapes
    shp.Delete
    Next shp
    RutaActual = ThisWorkbook.Path
    ActiveSheet.Range("B2").Select
    Do While ActiveCell.Offset(0, -1).Value <> Empty
    Set RangoImagen = ActiveCell.Offset(0, -1)
    ActiveSheet.Pictures.Insert(RutaActual & "\Fotos\" & RangoImagen.Value & ".jpg").Select
    Call AjusteDeFoto
    ActiveCell.Offset(1, 0).Select
    Loop
    Range("A1").Select
    On Error GoTo 0
    End Sub

    ResponderEliminar
    Respuestas
    1. Hola Ivan
      solo tienes que leer este mismo post, donde se indica la instrucción a emplear..
      en lugar de
      ActiveSheet.Pictures.Insert
      usa
      ActiveSheet.Shapes.AddPicture

      saludos

      Eliminar

Nota: solo los miembros de este blog pueden publicar comentarios.