Macro para Insertar una Imagen en una celda desde un boton.
Tengo un archivo de excel, alli tengo un boton1 (Sin formulario) y quiero saber si existe alguna macro que al darle click al boton1 me abra la opción de insertar imagen para que el usuario escoja la foto y la inserte en la hoja y además en me aparezca la ruta que seleccionó en la celda A32.
2 Respuestas
Adjudica esta macro a tu botón
Sub proceso() 'por luismondelo Application.Dialogs(xlDialogInsertPicture).Show End Sub
Te mando otra macro que hace lo que necesitas. En la celda A32 tenemos anotado la ruta deseada. Y la foto la insertará en la celda H5 (estas dos celdas las puedes cambiar en la macro)
Sub imagen()
'por luismondelo
ruta = Range("a32").Value
ChDir ruta
tope = Range("h5").Top
izq = Range("h5").Left
vfile = Application.GetOpenFilename("Archivos (*.jpg;*.bmp),*.jpg;*.bmp")
If vfile = False Then Exit Sub
ActiveSheet.Pictures.Insert(vfile).Select
Selection.ShapeRange.Top = tope
Selection.ShapeRange.Left = izq
Selection.ShapeRange.Height = 127
End Sub
Al principio de la macro puedes poner en cuál celda quieres la ruta y en cuál celda quieres la imagen, cambia las celdas que quieres en estas líneas de la macro:
ruta = "A32" 'celda en donde se pondrá la ruta
imagen = "D2" 'celda en donde se pondrá la imagen
Sub insertarimagen()
'Por.DAM
ruta = "A32" 'celda en donde se pondrá la ruta
imagen = "D2" '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
'.Show
If .Show Then
archivo = .SelectedItems.Item(1)
pos = InStrRev(archivo, "\")
wruta = Left(archivo, pos)
ActiveSheet.Pictures.Insert(archivo).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
.Placement = xlMoveAndSize
.PrintObject = True
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Top = arr
.ShapeRange.Left = izq
.ShapeRange.Height = hei
.ShapeRange.Width = wid
.ShapeRange.Name = archivo
End With
Range("D2").ShrinkToFit = True
End If
End With
Application.ScreenUpdating = True
End Sub