Macro para insertar fotos en Excel y que se queden fijas
He creado la siguiente macro para que me inserte fotos desde una carpeta a un Excel en función de un valor de la celda y hasta ahí funciona bien pero quiero que una vez insertadas se peguen como imagen en el Excel para que no esté "recalculando" el vinculo constantemente y no de error a las personas que no tengan acceso a la ruta. La idea es agregar a la macro una línea para que una vez insertado las imágenes al reporte, te seleccione todas las imágenes corte y pegue con formato de imagen. Lo he intentado con la la grabadora de macros sin mucho éxito.. ¿Cómo lo podría solucionar sobre este ejemplo?
Muchas gracias!
Sub FicherosCarpeta()
Dim Ruta As String
Dim fotos As Object
Dim rng As Range, celda As Range
On Error Resume Next
Application.ScreenUpdating = False
Dim img As Shape
On Error Resume Next
For Each img In ActiveSheet.Shapes
If img.Type = 11 Then img.Delete
Next
Ruta = "O:\05-compras\04-ventas\61\FOTOS 61\reducidas\"
Set Carpeta = fso.GetFolder("O:\05-compras\04-ventas\61\FOTOS 61\reducidas\")
Set ficheros = Carpeta.Files
Set rng = Worksheets("acc").Range("d4:d43")
For Each celda In rng
If Len(Trim(celda)) > 0 Then
Set r1 = Cells(celda.Row, "C")
r1.Select
Set fotos = ActiveSheet.Pictures.Insert("O:\05-compras\04-ventas\61\FOTOS 61\reducidas\" & celda.Value & ".JPG").Select
Selection.ShapeRange.LockAspectRatio = False
Selection.ShapeRange.Height = r1.Height - 15
Selection.ShapeRange.Width = r1.Width - 30
Selection.ShapeRange.Left = r1.Left + 6
Selection.ShapeRange.Top = r1.Top + 6
' insertar fotos en celda
ActiveSheet.DrawingObjects.Select
Selection.Placement = xlMoveAndSize
End If
Next celda
Set fso = Nothing
Set Carpeta = Nothing
Set ficheros = Nothing
Set rng = Nothing
Set r1 = Nothing
Set fotos = Nothing
Application.ScreenUpdating = True
End Sub
1 Respuesta
H o l a:
Quieres cortar la imagen y pegarla como con formato de imagen, pero no pusiste exactamente a cuál formato de imagen te refieres, ya que existen varios.
Te anexo la macro para cortar y pegar, le puse de ejemplo:
ActiveSheet.PasteSpecial Format:="Imagen (metarchivo mejorado)", Link:=False, DisplayAsIcon:=False
Estos son los otros formatos que existen (por lo menos hasta la versión 2007 de excel).
"Imagen (PNG)" "Imagen (JPEG)" "Imagen (GIF)" "Imagen (metarchivo mejorado)" "mapa de bits" "Objeto de dibujo de Microsoft Office"
Puedes consultar los formatos de pegado especial en el siguiente enlace:
https://support.office.com/es-es/article/Pegado-especial-e03db6c7-8295-4529-957d-16ac8a778719
Agregué esta instrucción a la macro, por que no me estaba borrando las imágenes, pero si no te sirve la puedes eliminar del código. Me parece que el tipo debe ser 13.
ActiveSheet. DrawingObjects.Delete
Quité algunas líneas de la macro que no son necesarias.
Sub FicherosCarpeta()
'Act.Por.Dante Amor
Application.ScreenUpdating = False
Dim Ruta As String
Dim celda As Range
Dim img As Shape
'
On Error Resume Next
'For Each img In ActiveSheet.Shapes
' If img.Type = 11 Then img.Delete
'Next
ActiveSheet.DrawingObjects.Delete
'
Ruta = "O:\05-compras\04-ventas\61\FOTOS 61\reducidas\"
'Ruta = "c:\trabajo\varios\"
For Each celda In Worksheets("acc").Range("D4:D43")
If Len(Trim(celda)) > 0 Then
ActiveSheet.Pictures.Insert(Ruta & celda.Value & ".JPG").Cut
ActiveSheet.PasteSpecial Format:="Imagen (metarchivo mejorado)", Link:=False, DisplayAsIcon:=False
Selection.ShapeRange.LockAspectRatio = False
Selection.ShapeRange.Height = Cells(celda.Row, "C").Height - 15
Selection.ShapeRange.Width = Cells(celda.Row, "C").Width - 30
Selection.ShapeRange.Left = Cells(celda.Row, "C").Left + 6
Selection.ShapeRange.Top = Cells(celda.Row, "C").Top + 6
Selection.Placement = xlMoveAndSize 'xlMove, xlFreeFloating
End If
Next celda
Application.ScreenUpdating = True
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Muchísimas gracias! Ahora funciona perfectamente como necesitaba :)
Una última duda para terminar de pulirlo.. no habrá forma de que al insertarlas las comprima también de forma que el archivo no pese tanto, ¿verdad?
De nuevo muchísimas gracias por tu ayuda, muy útil!
H o l a:
Intenta con cada uno de los formatos de pegado especial que te puse. Para que revises con cuál de ellos la imagen pesa menos.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
