Utilizar imágenes de una carpeta en un libro excel
Tengo dos libros de trabajo uno llamado Control horario mensual y otro llamado Códigoch y una carpeta llamada imágenes. La carpeta imágenes, contiene, como es lógico una serie de imágenes jpg que luego utilizo en los libros. Los dos libros son prácticamente iguales, uno de ellos (Control horario mensual) será el que utilicemos todos para insertar las horas de entrada y salida. El otro, será el que contiene el código a ejecutar con cada evento. El libro Códigoch y la carpeta imágenes están guardados en otra carpeta que he bautizado como prueba control, y pueden estar ubicadas en cualquier unidad del equipo (tiene que ser la que nos digan nuestros jefes y, en cualquier momento, pueden decidir cambiarla...) Lo que hago es que, al abrir el libro Control horario mensual, abro en segundo plano el que contiene el código con la siguiente instrucción colocada en un módulo de Control horario como auto_open (utilizo path para que localice la carpeta esté donde esté):
Application.ScreenUpdating = False
Workbooks.Open ThisWorkbook.Path & "\pruebacontrol\Códigoch.xlsm"
Application.Run "'Códigoch.xlsm'!abrir"
Después, para ejecutar el resto de eventos, utilizo el código de la tercera línea cambiando el nombre de la macro o módulo.
Hay una hoja, llamada "mes" en la que tengo una imagen que, al hacer click, debe realizar una serie de acciones y cambiar la imagen por otra. Si lo hago en el libro Códigoch, no me da ningún problema, pero si lo intento desde control horario, no me cambia la imagen... Supongo que el problema es que no localiza la carpeta imágenes. La macro que utilizo para cambiar la imagen es la siguiente:
Sub SeleccionarImagen()
If [h51].Value = "" Then
[h51].Value = "Borra"
Range("B7:F37,H7:J37").Select
'Range("H7").Activate
Selection.Locked = True
Range("a1").Select
Else: [h51].Value = ""
Range("B7:F37,H7:J37").Select
'Range("H7").Activate
Selection.Locked = False
Range("a1").Select
End If
Dim ImagenShape As Excel.Shape
Set ImagenShape = ActiveSheet.Shapes(Application.Caller)
If Not ImagenShape Is Nothing Then
CambiarImagen ImagenShape
Else
MsgBox "Llamada a función incorrecta"
End If
End Sub
Sub CambiarImagen(ImagenShapeActual As Excel.Shape)
On Error Resume Next 'Deshabilita la interrupción de ejecucion por errores
Application.ScreenUpdating = False 'Deshabilita la actualización de pantalla(evita los parpadeos)
Application.EnableEvents = False 'Deshabilita los eventos(para evitar que el codigo actual active otros codigos)
Dim i As Integer
Dim ImagenShapeNuevo As Excel.Shape
Dim ArchivoImagen As String
'Propiedades que se van a conservar de la imagen(se puden agregar mas)
Dim pName As String
Dim pOnAction As String
Dim pLeft As Single
Dim pTop As Single
Dim pWidth As Single
Dim pHeight As Single
Dim pPlacement As Long
Dim pLockAspectRatio As Long
'Se llama al cuadro de dialogo para seleccionar un archivo de imagen
If [h51].Value = "" Then
ArchivoImagen = Application.ThisWorkbook.Path & "\imágenes\borrar.jpg"
Application.Cursor = xlDefault
Else
ArchivoImagen = Application.ThisWorkbook.Path & "\imágenes\finborrado.jpg"
MsgBox "Selecciona en la columna " & Chr(34) & "OBSERVACIONES" & Chr(34) & " con el BOTÓN DERECHO DEL RATÓN y de UNA EN UNA, las celdas cuyo valor deseas borrar. Se abrirá un cuadro de diálogo solicitando la confirmación del borrado o el procedimiento a seguir para borrarla. Cuando hayas terminado, pulsa en " & Chr(34) & "Finalizar Borrado" & Chr(34) & ".", vbInformation + vbOKOnly, "ATENCIÓN"
Application.Cursor = xlNorthwestArrow
End If
'If ArchivoImagen <> "Falso" Then 'Si se seleccionó un archivo
If Not ImagenShapeActual Is Nothing Then 'Si hay una imagen que cambiar
'Obtener las propiedades de la imagen
pName = ImagenShapeActual.Name
pOnAction = ImagenShapeActual.OnAction 'Importante
pLeft = ImagenShapeActual.Left
pTop = ImagenShapeActual.Top
pWidth = ImagenShapeActual.Width
pHeight = ImagenShapeActual.Height
pPlacement = ImagenShapeActual.Placement
pLockAspectRatio = ImagenShapeActual.LockAspectRatio
'Se inserta la nueva imagen especificando que sea una copia independiente del archivo original(msoFalse)
'y que se guarde con el documento de Excel (msoCTrue) para evitar que el logo no se vea en otros equipos
Set ImagenShapeNuevo = ActiveSheet.Shapes.AddPicture(ArchivoImagen, msoFalse, msoCTrue, pLeft, pTop, pWidth, pHeight)
If Not ImagenShapeNuevo Is Nothing Then 'Si se insertó correctamente la nueva imagen
ImagenShapeActual.Delete 'Elimina la imagen original
'Agrega las propiedades de la imagen original a la nueva imagen
ImagenShapeNuevo.Name = pName
ImagenShapeNuevo.OnAction = pOnAction 'Importante
ImagenShapeNuevo.Left = pLeft
ImagenShapeNuevo.Top = pTop
ImagenShapeNuevo.Width = pWidth
ImagenShapeNuevo.Height = pHeight
ImagenShapeNuevo.Placement = pPlacement
ImagenShapeNuevo.LockAspectRatio = pLockAspectRatio
Set ImagenShapeNuevo = Nothing
End If
Set ImagenShapeActual = Nothing
End If
'End If
Application.ScreenUpdating = True 'Habilita la actualización de pantalla(para mostrar el cambio realizado)
Application.EnableEvents = True 'Habilita los eventos
End Sub
Este código lo conseguí gracias a la ayuda de un compañero del foro, y está ubicada en el libro Códigoch, pero, claro, yo la ejecuto desde Control horario. Funciona todo menos el cambio de imagen y supongo que es, como decía, por la sencilla razón de que no localiza la carpeta ni las imágenes, aunque no me lanza ningún mensaje de error.
El motivo de hacer esto así es que, si algún día tengo que cambiar el código, sólo tendría que hacerlo en un libro, y no en los que cada usuario tenga en su ordenador (pueden ser más de 100 usuarios)
¿Podéis
