Insertar imagen en rango determinado y eliminar la imagen anterior

Tengo un UF donde (con la ayuda de DAM) puedo insertar 18 imágenes en celdas predeterminadas.

Private Sub CommandButton2_Click()
'Por.DAM

ruta = "AL1" 'celda en donde se pondrá la ruta
imagen = "T2" 'celda en donde se pondrá la imagen
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Seleccione archivo de imagen"
.Filters.Clear
.Filters.Add "Todos los archivos", "*.*"
.Filters.Add "*.jpg", "*.jpg"
.Filters.Add "*.bmp", "*.bmp"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & ("\IMAGENES DESDE RADIANT") & "\IMAGENES HEC"
'.Show
If .Show Then
ARCHIVO2 = .SelectedItems.Item(1)
pos = InStrRev(ARCHIVO2, "\")
wruta = Left(ARCHIVO2, pos)
ActiveSheet.Pictures.Insert(ARCHIVO2).Select
arr = Range(imagen).Top
izq = Range(imagen).Left
hei = Range(imagen).Offset(1, 0).Top - arr
wid = Range(imagen).Offset(0, 1).Left - izq
With Selection
Selection.ShapeRange.ZOrder msoSendToBack
.Placement = xlMoveAndSize
.PrintObject = True
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Top = arr
.ShapeRange.Left = izq
.ShapeRange.Height = hei
.ShapeRange.Width = wid
.ShapeRange.Name = ARCHIVO2
End With
Range("T2").ShrinkToFit = True
End If
End With
Application.ScreenUpdating = True
Image2.Picture = LoadPicture(ARCHIVO2, 3, 3, Default)

End Sub

A su vez, la imagen que inserte en la hoja, la veo en el UF (en una imagen al lado del CommandButton):

Image2.Picture = LoadPicture(ARCHIVO2, 3, 3, Default)

Si quiero cambiar una de las 18 imágenes antes de cerrar el registro, necesito que al clickear en el botón para seleccionar la imagen, seleccione la imagen que ya había insertado, la elimine y poder ejecutar la macro que puse más arriba, ya que si no, va pegando imágenes una arriba de la otra...

¿Alguno me podría ayudar a verificar si la celda tiene imágenes y eliminarlas antes de ejecutar la macro?

1 respuesta

Respuesta
1

Te anexo la macro con los cambios

Private Sub CommandButton2_Click()
'Por.Dante Amor
    ruta = "AL1" 'celda en donde se pondrá la ruta
    imagen = "T2" 'celda en donde se pondrá la imagen
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione archivo de imagen"
        .Filters.Clear
        .Filters.Add "Todos los archivos", "*.*"
        .Filters.Add "*.jpg", "*.jpg"
        .Filters.Add "*.bmp", "*.bmp"
        .FilterIndex = 2
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & ("\IMAGENES DESDE RADIANT") & "\IMAGENES HEC"
        '.Show
        If .Show Then
            ARCHIVO2 = .SelectedItems.Item(1)
            pos = InStrRev(ARCHIVO2, "\")
            wruta = Left(ARCHIVO2, pos)
            ActiveSheet.Pictures.Insert(ARCHIVO2).Select
            'arr = Range(imagen).Top
            'izq = Range(imagen).Left
            'hei = Range(imagen).Height
            'wid = Range(imagen).Width
            On Error Resume Next
            ActiveSheet.DrawingObjects("figura").Delete
            On Error GoTo 0
            With Selection
                Selection.ShapeRange.ZOrder msoSendToBack
                .Name = "figura"
                .Placement = xlMoveAndSize
                .PrintObject = True
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.Top = Range(imagen).Top
                .ShapeRange.Left = Range(imagen).Left
                .ShapeRange.Height = Range(imagen).Height
                .ShapeRange.Width = Range(imagen).Width
                '.ShapeRange.Name = ARCHIVO2
            End With
            Range("T2").ShrinkToFit = True
        End If
    End With
    Application.ScreenUpdating = True
    Image2.Picture = LoadPicture(ARCHIVO2, 3, 3, Default)
End Sub

.

.Sal u dos. Dante Amor. Si es lo que necesitas. R ecuerda valorar la respuesta. G racias

.

Hola Dante. Gracias por tu pronta respuesta. Lo intenté. La imagen me aparece correctamente en el UF, aunque no en la Hoja (Hoja7 del Libro). Será que habrá que darle la orden que borre las imágenes antes de pegar el "archivo2"?

Dante. El libro es una base de datos de informes médicos. Con los UF cargo los datos de cada paciente (personas). Al final (hoja7) fabrique unas celdas con el tamaño y proporción

En estas celdas pego las imágenes que voy guardando de cada paciente en una carpeta y en formato JPG:

ThisWorkbook.Path & ("\IMAGENES DESDE RADIANT") & "\IMAGENES HEC"

En la macro, estos botones pegan la imagen en esas celdas, y la idea es verlas también en el UF (así no tengo que manupular la Hoja)

, y luego de elegir las imagenes adecuadas, mediante una macro, genero el informe (las imágenes) en formato PDF y son las imágenes que se suben a la historia clínica electónica y también se le entregan al paciente. 

Son 18 imágenes por informe. Voy pegando las imágenes y al final, decido cambiar una sola, quisiera usar el mismo botón para sacar la que había puesto al principio y pegar otra que está en la misma carpeta.

Espero no aturdirte con tanta explicación.

Pero si vas pegando 18 imágenes y luego quieres borrar una de ellas, ¿pero cómo saber cuál de ellas?

Cada imagen tiene su botón. El botón uno, inserta la imagen 1 (archivo1) en la hoja7 range A2. El botón 2 la imagen (archivo2) en range T2. Cada botón tiene su macro. La imagen 3 (archivo3) iría en A22 y así sucesivamente. 6 imágenes por página. Para cambiar una imagen, eliges su botón. Si quieres te envío a tu mail un pdf terminado (confeccionado manipulando la hoja 7, cosa q quiero evitar). No lo subo en todoexpertos porque son documentos personales y tienen los nombres de los pacientes. 

Una vez generado el pdf con las imágenes se borran todas y la hoja 7 queda en blanco. 

Borra todas las imágenes de las hojas, para empezar desde cero.

El siguiente código es para la imagen del botón2

Private Sub CommandButton2_Click()
'Por.Dante Amor
    ruta = "AL1" 'celda en donde se pondrá la ruta
    imagen = "T2" 'celda en donde se pondrá la imagen
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Seleccione archivo de imagen"
        .Filters.Clear
        .Filters.Add "Todos los archivos", "*.*"
        .Filters.Add "*.jpg", "*.jpg"
        .Filters.Add "*.bmp", "*.bmp"
        .FilterIndex = 2
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & ("\IMAGENES DESDE RADIANT") & "\IMAGENES HEC"
        '.Show
        If .Show Then
            ARCHIVO2 = .SelectedItems.Item(1)
            pos = InStrRev(ARCHIVO2, "\")
            wruta = Left(ARCHIVO2, pos)
            ActiveSheet.Pictures.Insert(ARCHIVO2).Select
            'arr = Range(imagen).Top
            'izq = Range(imagen).Left
            'hei = Range(imagen).Height
            'wid = Range(imagen).Width
            On Error Resume Next
            ActiveSheet.DrawingObjects("figura2").Delete
            On Error GoTo 0
            With Selection
                Selection.ShapeRange.ZOrder msoSendToBack
                .Name = "figura2"
                .Placement = xlMoveAndSize
                .PrintObject = True
                .ShapeRange.LockAspectRatio = msoTrue
                .ShapeRange.Top = Range(imagen).Top
                .ShapeRange.Left = Range(imagen).Left
                .ShapeRange.Height = Range(imagen).Height
                .ShapeRange.Width = Range(imagen).Width
                '.ShapeRange.Name = ARCHIVO2
            End With
            Range("T2").ShrinkToFit = True
        End If
    End With
    Application.ScreenUpdating = True
    Image2.Picture = LoadPicture(ARCHIVO2, 3, 3, Default)
End Sub

En el código, estoy poniendo estas líneas:

'Para nombrar la figura, significa que cada que pongas una imagen, siempre se va a llamar "figura2"
.Name = "figura2"

'Para borrar la figura, la macro siempre va a borrar la imagen con el nombre "figura2"
ActiveSheet.DrawingObjects("figura2").Delete


Lo mismo tienes que hacer para los demás botones.

Genial Dante!!!!! un lujo!!!! No sabés como te agradezco!
... pero hay un pequeño detalle.... borra la imagen anterior y pega la nueva... pero le falta el tamaño de la imagen

Cambia esta línea

Imagen = "T2" 'celda en donde se pondrá la imagen

Por el rango de celdas donde va a estar la imagen, por ejemplo:

Imagen = "T2:AK20" 'rango de celdas en donde se pondrá la imagen

Sal u dos, no olvides cambiar la valoración a la respuesta.

¡Gracias Dante!. Ha quedado excelente! No sabes lo agradecido que estoy!!!!! Tu trabajo es ejemplar. Es muy grato recibir una mano de alguien sin pedir nada a cambio... Un abrazo.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas