MACRO PARA INSERTAR IMAGENES (SHAPES.ADDPICTURE)

[Nestorio2002]

Buenos días,

Tengo un problema que no se resolver y me gustaría saber si alguien puede ayudarme con la solución. Tengo una macro para insertar imágenes, la macro funciona correctamente pero inserta las imágenes vinculadas. Al enviar el fichero por email las imágenes desaparecen. Me gustaría poder modificar la macro para que inserte la imagen rompiendo el vínculo con el fichero origen. He averiguado que para conseguirlo necesito usar el método Shapes.Addpicture, pero no se como hacer las modificaciones en la macro. Podría alguien ayudarme? GRACIAS!!!! Esta es la macro:

Sub BorrarImagenes()
''Esta función recorre todas las imagenes del libro activo y las borra.
  Dim Imagen As Picture
  For Each Imagen In ActiveSheet.Pictures
      Imagen.Delete
  Next Imagen
End Sub

Sub InsertaFotoCelda1(RutaImagen As String, CeldaDestino As Range)
''Esta función inserta el objeto imagen en la celda correspondiente
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(RutaImagen) = "" Then Exit Sub
    
    '' Importa la imagen
    Set p = ActiveSheet.Pictures.Insert(RutaImagen)
    '' Calcula la posición de la celda destino para adaptar la imagen
    With CeldaDestino
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    '' Posiciona la imagen dentro de la celda.
    With p
        .Top = t
        .Left = l
        .Width = w
        .Height = h
    End With
    '' Liberamos el objeto imagen
    Set p = Nothing
    
End Sub

Sub MACRO_FOTOS_DAME_CLICK()

    
    Dim i As Double
    
    Dim Ruta As String
    Dim Path As String
    
    Ruta = "C:\Users\ndelcast\Desktop\FALL16 PICTURES NEST\"

    BorrarImagenes
    
    For i = 2 To 600
    
                ''El Cell(Linea, Columna) que busca en el excel
                MODELO = Cells(i, 8)
                            
    
                NOMBRE = MODELO
    
                ''Donde devuelve la foto.
                Cells(i, 10).Select
               ' ActiveCell.RowHeight = 12.75
               ' ActiveCell.ColumnWidth = 10.71
                
                Path = Ruta & NOMBRE & ".tif"
                InsertaFotoCelda1 Path, Cells(i, 10)
            
                On Error Resume Next

                ' Error 1004 producirá un error no encontrar la foto
                Error 1004
                
                NOMBRE = 0
      Next i
    
    Ruta = "C:\Users\ndelcast\Desktop\FALL16 PICTURES NEST\"
    
    For i = 2 To 600
    
                ''El Cell(Linea, Columna) que busca en el excel
                MODELO = Cells(i, 11)
                            
    
                NOMBRE = MODELO
    
                ''Donde devuelve la foto.
                Cells(i, 12).Select
               ' ActiveCell.RowHeight = 12.75
               ' ActiveCell.ColumnWidth = 10.71
                
                Path = Ruta & NOMBRE & ".jpg"
                InsertaFotoCelda1 Path, Cells(i, 12)
            
                On Error Resume Next

                ' Error 1004 producirá un error no encontrar la foto
                Error 1004
                
                NOMBRE = 0
      Next i

Ruta = "C:\Users\ndelcast\Desktop\FALL16 PICTURES NEST\"
    
    For i = 2 To 600
    
                ''El Cell(Linea, Columna) que busca en el excel
                MODELO = Cells(i, 13)
                            
    
                NOMBRE = MODELO
    
                ''Donde devuelve la foto.
                Cells(i, 14).Select
               ' ActiveCell.RowHeight = 12.75
               ' ActiveCell.ColumnWidth = 10.71
                
                Path = Ruta & NOMBRE & ".tif"
                InsertaFotoCelda1 Path, Cells(i, 14)
            
                On Error Resume Next

                ' Error 1004 producirá un error no encontrar la foto
                Error 1004
                
                NOMBRE = 0
      Next i

End Sub

 

[Antoni]

Prueba así:

Sub BorrarImagenes()
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub

Sub InsertaFotoCelda1(RutaImagen As String, CeldaDestino As Range)
On Error Resume Next
With CeldaDestino
   ActiveSheet.Shapes.AddPicture RutaImagen, False, True, .Left, .Top, .Width, .Height
End With
End Sub

Sub MACRO_FOTOS_DAME_CLICK()
Dim i As Long
Dim Ruta As String
BorrarImagenes
Ruta = "C:\Users\ndelcast\Desktop\FALL16 PICTURES NEST\"
For i = 2 To Range("H" & Rows.Count).End(xlUp).Row
   InsertaFotoCelda1 Ruta & Cells(i, 8) & ".tif", Cells(i, 10)
   InsertaFotoCelda1 Ruta & Cells(i, 11) & ".tif", Cells(i, 12)
   InsertaFotoCelda1 Ruta & Cells(i, 13) & ".tif", Cells(i, 14)
Next i
End Sub

 

[Héctor Miguel]

hola, a todos !

Hace 3 horas, Macro Antonio dijo:

Prueba así:

Sub BorrarImagenes()
ActiveSheet.Shapes.SelectAll
Selection.Delete
End Sub

sugiero usar con cautela este tipo de acciones que borran TODOS los objetos "shape"

hay muchos objetos que "pasan" por esa colección y (según la version donde se ejecute) podría incluso eliminar los desplegables de los (auto)filtros y esa hoja quedará "corrupta" y jamás volverás a ver esos dropdowns

para eliminar solo objetos imagen... activesheet.pictures.delete

saludos,

hector.