Macro para romper vinculo de imagen para que este fija
He aprendido mucho en el foro, pero ahora me tope con un detalle, tengo este código:
Sub insertarimagen()
'Por.DAM
On Error Resume Next
ruta = ActiveWorkbook.Path & "\"
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
imagen = Cells(i, "A")
Set img = ActiveSheet.Pictures.Insert(ruta & imagen)
With Cells(i, 2)
Arr = .Top
Izq = .Left
Anc = .Offset(0, 1).Left - .Left
Alt = .Offset(1, 0).Top - .Top
End With
With img
'.Name = numimg
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arr
.Left = Izq
.Width = Anc
.Height = Alt
End With
Set img = Nothing
Next
End Sub
Que me extrae la imagen de una carpeta siempre y cuando coincida con la descripción, hasta ahí todo bien, pero si quiero mandar el archivo a los jefes, cuando lo abren les marca el siguiente error en la imagen "No puede mostrar la imagen porque se rompió el vínculo o se ha cambiado de ubicación" y son 284 imágenes, entonces me marca 284 errores, supuse que tendría que mandar la carpeta de las imágenes con el libro de excel, para que me "muestre las imágenes" y de hecho funciono, ¿mi duda es se puede ajustar la macro para que pegue la imagen y no genere un vinculo que es el que genera error?.
1 Respuesta
Hola tengo Excel 2010, entonces que cree que pueda ser, no se si tenga que ver que tengo XP Service Pack 3, porque de plano "rompe el vínculo" y me arroja el error mencionado arriba, si no esta junto a la carpeta que extrae las imágenes o que me puede sugerir?
Saludos
Es por la versión. Ya me había pasado con alguien más.
Prueba lo siguiente. Inserta un image de los controles activex y ejecuta este código.
Sub im() 'Por.DAM ruta = "c:\trabajo\varios\" arch = "foto1.jpg" ActiveSheet.Image1.Picture = LoadPicture(ruta & arch) End Sub
cambia ruta por la ruta donde tengas una imagen
Cambia foto1.jpg por el nombre de archivo que tenga una image
Ejecuta la macro, deberá insertar la imagen en el control image, guarda el archivo, abre el archivo en otro lado donde no exista la imagen y me cuentas.
Ya lo verifique, como me indicaste y si me muestra la imagen, aunque este en otra PC
Cambio de macro. Borra todas tus imágenes y utiliza esta macro. Lo que va a hacer es crearte un control Activex (image), uno para cada celda y te lo va a poner en la columna B; y en cada image va a insertar la imagen
Sub insertarimagen()
'Por.Dante Amor
On Error Resume Next
ruta = ActiveWorkbook.Path & "\"
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
imagen = Cells(i, "A")
With Cells(i, 2)
arr = .Top
izq = .Left
anc = .Offset(0, 1).Left - .Left
alt = .Offset(1, 0).Top - .Top
End With
ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", _
Link:=False, DisplayAsIcon:=False, Left:=izq, Top:=arr, _
Width:=anc, Height:=alt).Select
ActiveSheet.OLEObjects(Selection.Name).Object.Picture = LoadPicture(ruta & imagen)
Next
End SubGuarda el archivo y ábrelo en otra PC para que hagas la prueba.
Hola, ya hice la prueba en mi PC y en otra máquina y si quedo, aunque salió el detalle de que el archivo con las 284 imágenes, no pasaba de 1 MB y ahora pesa 60 MB y se tarda en abrir, ¿se puede ajustar?
Guarda las imágenes como jpg y luego las cargas
Ya lo hice, cambie la extensión e hice una prueba con 10 imágenes y peso 2.5 MB, cuando en si deben pesar 50 kb, ¿a qué crees que se deba?
Eso corresponde a la administración de windows, cuando insertaste la imágenes con la primera instrucción no cargaba las imágenes en el archivo, solamente tenía la dirección, ahora sí estás cargando las imágenes en un control, además el control image tiene sus propiedades, supongo que por eso se hace muy pesado.
Me recomendarías que haga el archivo en otra versión de excel,haber si al guardar no pesa tanto? o crees que suceda lo mismo?
En la versión 2007 guarda la imagen y no tengo error cuando abro el archivo en otra pc
OK.mira dejalo reviso en una maquina con 2007 y en cuanto lo confirme, califico la pregunta
Saludos
No te preocupes lo importante es que te funcione, de hecho las dos soluciones funcionan pero la administración de los archivos corresponde a las versiones de office
¡Gracias! y disculpa por la demora, pero tarde en encontrar una máquina con otro offfice distinto al 2010 y si se guardo con menor peso, como siempre me has salvado
