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
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