Ayuda con Imágenes Insertadas Macros

Edwin buenas tardes. Necesito tu apoyo para resolver dos asuntos particulares. Estoy haciendo un catálogo de productos el cual inserta 5 imágenes a la vez en celdas que están COMBINADAS. Las imágenes las extrae de una carpeta que está en el mismo directorio. Esto ya está resuelto y lo hacer muy bien. También, antes de insertar las siguientes 5 imágenes, borra las anteriores para evitar que la hoja se sature. Eso también lo hace. El problema es que tengo imágenes que no tienen el mismo tamaño: algunas son cuadradas y otras rectangulares. Las que son cuadradas caben dentro de las celdas combinadas, pero las rectangulares se salen en su altura del área de celdas combinadas.
Otro detalle es que todas las imágenes las coloca partiendo de la esquina superior izquierda pero quisiera saber si hay alguna instrucción que las centre en las celdas combinadas y si la imagen es más grande que la ajuste al tamaño de las celdas combinadas GUARDANDO SUS PROPORCIONES.
Espero haberme explicado y te anexo el código para que tengas una mejor visión de lo que deseo plantear. Gracias de antemano por tu valiosa ayuda.
Private Sub Imagen_Siguiente()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    ActiveSheet.Unprotect Password:="123654"
    Application.StatusBar = "Procesando la información.... Favor de esperar"
' Rutina para eliminar cualquier imágen insertada antes de darle "siguiente" o "atrás"
    Control = Range("CA12").Value
    If Control <> "" Then
        For I = 12 To 16
            Nombre = Range("CA" & I).Value
            On Error Resume Next
            ActiveSheet.Shapes(Nombre).Select
            ActiveSheet.Shapes(Nombre).Delete
        Next
    Else
    End If
' Se inserta la imagen 1 miniatura
    Ruta = ThisWorkbook.Path
    Ruta = Ruta & "\Ambar_2.jpg"
    ActiveSheet.Pictures.Insert(Ruta).Select
    Foto1 = Selection.Name
    Range("CA12") = Foto1
    'se obtiene la ubicación de la celda Q11
    tope = Range("Q11:Y18").Top
    izq = Range("Q11:Y18").Left
    alto = Range("Q11:Y18").Height
    ancho = Range("Q11:Y18").Width
    'se ubica la imagen sobre la celda Q11
    Selection.ShapeRange.Top = tope
    Selection.ShapeRange.Left = izq
    Selection.ShapeRange.Height = alto
    Selection.ShapeRange.Width = ancho
' Se inserta la imagen 2 miniatura
    Ruta = ThisWorkbook.Path
    Ruta = Ruta & "\Ambar_1.jpg"
    ActiveSheet.Pictures.Insert(Ruta).Select
    Foto2 = Selection.Name
    Range("CA13") = Foto2
    'se obtiene la ubicación de la celda Q20
    tope = Range("Q20:Y27").Top
    izq = Range("Q20:Y27").Left
    alto = Range("Q20:Y27").Height
    ancho = Range("Q20:Y27").Width
    'se ubica la imagen sobre la celda Q20
    Selection.ShapeRange.Top = tope
    Selection.ShapeRange.Left = izq
    Selection.ShapeRange.Height = alto
    Selection.ShapeRange.Width = ancho
' Se inserta la imagen 3 miniatura
    Ruta = ThisWorkbook.Path
    Ruta = Ruta & "\Avellana_1.jpg"
    ActiveSheet.Pictures.Insert(Ruta).Select
    Foto3 = Selection.Name
    Range("CA14") = Foto3
    'se obtiene la ubicación de la celda Q29
    tope = Range("Q29:Y36").Top
    izq = Range("Q29:Y36").Left
    alto = Range("Q29:Y36").Height
    ancho = Range("Q29:Y36").Width
    'se ubica la imagen sobre la celda Q29
    Selection.ShapeRange.Top = tope
    Selection.ShapeRange.Left = izq
    Selection.ShapeRange.Height = alto
    Selection.ShapeRange.Width = ancho
' Se inserta la imagen 4 miniatura
    Ruta = ThisWorkbook.Path
    Ruta = Ruta & "\Ambar_1.jpg"
    ActiveSheet.Pictures.Insert(Ruta).Select
    Foto4 = Selection.Name
    Range("CA15") = Foto4
    'se obtiene la ubicación de la celda D29
    tope = Range("D29:L36").Top
    izq = Range("D29:L36").Left
    alto = Range("D29:L36").Height
    ancho = Range("D29:L36").Width
    'se ubica la imagen sobre la celda D29
    Selection.ShapeRange.Top = tope
    Selection.ShapeRange.Left = izq
    Selection.ShapeRange.Height = alto
    Selection.ShapeRange.Width = ancho
' Se inserta la imagen 5 Amplificada
    Ruta = ThisWorkbook.Path
    Ruta = Ruta & "\Ambar_1.jpg"
    ActiveSheet.Pictures.Insert(Ruta).Select
    Foto5 = Selection.Name
    Range("CA16") = Foto5
    'se obtiene la ubicación de la celda AC12
    tope = Range("AC12:AX28").Top
    izq = Range("AC12:AX28").Left
    alto = Range("AC12:AX28").Height
    ancho = Range("AC12:AX28").Width
    'se ubica la imagen sobre la celda AC12
    Selection.ShapeRange.Top = tope
    Selection.ShapeRange.Left = izq
    Selection.ShapeRange.Height = alto
    Selection.ShapeRange.Width = ancho
    Range("AB9").Select
End Sub

1 respuesta

Respuesta
1
Para la imágenes rectangulares tendrías que hacer un rango rectangular o transformarlas antes de insertarla en Excel...
Para darle nombre a la imagen es al revés... es decir hay que cambiar:
...
Foto1 = Selection.Name
................ Por ............
Selection.Name = "Foto1"
Otra cosa importante es que al pasar el ancho y el alto igual la imagen quedará cuadrada.
...
alto = Range("Q11:Y18").Height
ancho = Range("Q11:Y18").Width
...
Pero si la imagen es rectangular entra a jugar la relación de aspecto y seguirá rectangular, si quieres que la imagen quede cuadrada, al momento de insertarla la puedes hacer cuadrada algo como ...
...
Worksheets(1). Shapes. AddPicture("C:\Ambar_2.jpg", True, True, 100, 100, 70, 70).Select
...
Y luego lo cuadras en el rango...
...
' Se obtiene la ubicación de la celda Q11
    tope = Range("Q11:Y18").Top
    izq = Range("Q11:Y18").Left
    alto = Range("Q11:Y18").Height
    ancho = Range("Q11:Y18").Width
' Se ubica la imagen sobre la celda Q11
    Selection.ShapeRange.Top = tope + 10
    Selection.ShapeRange.Left = izq + 10
...
Para que quede centrada le puedes sumar al Top y al Left y así no quedará desde la esquina superior, observa que al código de arriba en top y left se les sumo 10.
Éxitos no olvides calificar para cerrar la pregunta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas