Insertar imagen y aumentarla de tamaño
Estoy aprovechando el código que Dante modificó para otro usuario de todoexpertos hace 2 semanas y que lo he podido reaprovechar para mi pero tengo 2 problemas:
1º) Le he insertado un botón activeX para que al pulsarlo me inserte las fotos pero al ejecutar la macro me borra también el botón y me inserta las fotos correctamente, ¿cómo evito que se borre el botón?.
2º) Necesitaría que después de insertadas las fotos al pinchar en cualquiera de ellas apareciera más grande en un formulario por ejemplo o de cualquier otra forma.
El código es:
Sub InsertarImagenes()
'Por.Dante Amor
Application.ScreenUpdating = False
ActiveSheet.DrawingObjects.Delete
u = Range("A" & Rows.Count).End(xlUp).Row
Rows("1:" & u).RowHeight = 60
Columns("B:B").ColumnWidth = 15
ruta = "C:\Users\RUBEN\Desktop\FOTOS\"
For i = 1 To u
arch = Dir(ruta & Cells(i, "A") & ".*")
If arch <> "" Then
With Cells(i, "B")
Arriba = .Top + 1
Izquierda = .Left + 1
Ancho = .Width - 2
Alto = .Height - 2
End With
'
Set fotografia = ActiveSheet.Pictures.Insert(ruta & arch)
With fotografia
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arriba
.Left = Izquierda
.Width = Ancho
.Height = Alto
End With
Set fotografia = Nothing
End If
Next
Application.ScreenUpdating = True
MsgBox "Imágenes insertadas"
End Sub
Inserto una imagen:
H o l a:
- Te anexo la macro actualizada para que no borre tu commandbutton, cambia en la macro "CommandButton1" por el nombre de tu commandbutton.
Private Sub CommandButton1_Click()
'Por.Dante Amor
Application.ScreenUpdating = False
'ActiveSheet.DrawingObjects.Delete
For Each img In ActiveSheet.DrawingObjects
If img.Name <> "CommandButton1" Then
img.Delete
End If
Next
'
u = Range("A" & Rows.Count).End(xlUp).Row
Rows("1:" & u).RowHeight = 60
Columns("B:B").ColumnWidth = 15
ruta = "C:\Users\RUBEN\Desktop\FOTOS\"
'ruta = "C:\trabajo\fotos\"
For i = 1 To u
arch = Dir(ruta & Cells(i, "A") & ".*")
If arch <> "" Then
With Cells(i, "B")
Arriba = .Top + 1
Izquierda = .Left + 1
Ancho = .Width - 2
Alto = .Height - 2
End With
'
Set fotografia = ActiveSheet.Pictures.Insert(ruta & arch)
With fotografia
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoFalse
.Top = Arriba
.Left = Izquierda
.Width = Ancho
.Height = Alto
End With
Set fotografia = Nothing
End If
Next
Application.ScreenUpdating = True
MsgBox "Imágenes insertadas"
End Sub- Para hacer grande la imagen o pequeña, pon lo siguiente en los eventos de thisworkbook. El siguiente código es para activar la tecla F4, cada que presiones la tecla F4 se ejecutará la macro CrecerImagen.
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Por.Dante Amor
Application.OnKey "{F4}", ""
End Sub
'
Private Sub Workbook_Open()
'Por.Dante Amor
Application.OnKey "{F4}", "CrecerImagen"
End SubInstrucciones para poner la macro en los eventos ThisWorkbook
- Abre tu libro de excel
- Para abrir Vba-macros y poder pegar la macro, Presiona Alt + F11
- Del lado izquierdo dice: VBAProject, abajo dale doble click a ThisWorkbook
- En el panel del lado derecho copia la macro
- Pon la siguiente macro en un módulo:
Sub CrecerImagen() 'Por.Dante Amor On Error Resume Next n = Selection.Name werr = Err.Number If werr <> 0 Then MsgBox "Selecciona una gráfica" Exit Sub End If On Error GoTo 0 If InStr(1, n, "Imagen") = 0 Then MsgBox "Selecciona una Imagen" Exit Sub End If If Selection.Height > 400 Then Selection.Height = [B1].Height Selection.Width = [B1].Width Else Selection.Height = 450 Selection.Width = 450 End If End Sub
Funcionamiento:
- Guarda el archivo y vuelve abrirlo para que se active la tecla F4.
- Carga las imágenes.
- Revisa que todas las imágenes que se cargaron tienen un nombre como "Imagen 10" o "10 Imagen", el caso es que tengan la palabra "Imagen".
- Selecciona una imagen y presiona la tecla F4
- La imagen crecerá.
- Si presionas nuevamente la tecla F4 la imagen se reducirá.
Cuando cierres el archivo la tecla F4 se desactivará con este evento:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Por.Dante Amor
Application.OnKey "{F4}", ""
End Sub':) ':)
