Insertar imagen en cuadro de texto en un rango determinado
Utilice el grabador de macros para justamente obtener el código para poder insertar un cuadro de texto y luego una imagen en el cuadro de texto pudiendo darle transparencia a la misma, quedando como una marca de agua en documento de Excel.
La macro es la siguiente:
Sub Macro3()
'
' Macro3 Macro
'
'
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 174, 942, 252, 126) _
.Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture _
"C:\Users\DanielHF\Pictures\publicidad\1.jpg"
.TextureTile = msoFalse
End With
Selection.ShapeRange.IncrementLeft 0.75
Selection.ShapeRange.IncrementTop -12.75
Selection.ShapeRange.IncrementLeft -24
Selection.ShapeRange.IncrementTop -18
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture _
"C:\Users\DanielHF\Pictures\publicidad\1.jpg"
.Transparency = 0.76
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
End Sub
Quisiera poder hacer que la macro, en vez de tener ya la ruta predefinida de la imagen, se pueda elegir
Asi como también elegir el rango en donde se la ubicara.
Te anexo la macro actualizada, primero te pide que selecciones el archivo, después selecciona la celda, por último se inserta la imagen.
Sub Macro3()
'Act.Por.Dante Amor
'Insertar imagen
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Selecciona imagen"
.Filters.Clear
.Filters.Add "Todos los archivos", "*.*"
.Filters.Add "jpg", "*.jp*"
.Filters.Add "bmp", "*.bm*"
.Filters.Add "png", "*.pn*"
.FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
If Not .Show Then Exit Sub
archivo = .SelectedItems.Item(1)
End With
'
On Error Resume Next
Set celda = Application.InputBox("Selecciona celda destino", _
Default:=Selection.Address, Type:=8)
If celda Is Nothing Then Set celda = ActiveCell
'
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 174, 942, 252, 126).Select
With Selection
.Top = celda.Top
.Left = celda.Left
With .ShapeRange.Fill
.Visible = msoTrue
.UserPicture archivo
.TextureTile = msoFalse
.Transparency = 0.76
.RotateWithObject = msoTrue
End With
End With
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
Excelente justo lo que buscaba, si en caso quisiera poner la imagen en f10:i17 como tendría que ajustar la macro?, muchas gracias Dante Amor
Anexo la macro
Sub Macro3()
'---
' Por.Dante Amor
'---
'Insertar imagen
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Selecciona imagen"
.Filters.Clear
.Filters.Add "Todos los archivos", "*.*"
.Filters.Add "jpg", "*.jp*": .Filters.Add "bmp", "*.bm*"
.Filters.Add "png", "*.pn*": .FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
If Not .Show Then Exit Sub
archivo = .SelectedItems.Item(1)
End With
'
' On Error Resume Next
' Set celda = Application.InputBox("Selecciona celda destino", _
' Default:=Selection.Address, Type:=8)
' If celda Is Nothing Then Set celda = ActiveCell
Set celda = Range("F10:I17")
'
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 174, 942, 252, 126).Select
With Selection
.Top = celda.Top
.Left = celda.Left
.Width = celda.Width
.Height = celda.Height
With .ShapeRange.Fill
.Visible = msoTrue
.UserPicture archivo
.TextureTile = msoFalse
.Transparency = 0.76
.RotateWithObject = msoTrue
End With
End With
End SubSub Macro3()
'---
' Por.Dante Amor
'---
'Insertar imagen
'
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Selecciona imagen"
.Filters.Clear
.Filters.Add "Todos los archivos", "*.*"
.Filters.Add "jpg", "*.jp*": .Filters.Add "bmp", "*.bm*"
.Filters.Add "png", "*.pn*": .FilterIndex = 2
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
If Not .Show Then Exit Sub
archivo = .SelectedItems.Item(1)
End With
'
' On Error Resume Next
' Set celda = Application.InputBox("Selecciona celda destino", _
' Default:=Selection.Address, Type:=8)
' If celda Is Nothing Then Set celda = ActiveCell
Set celda = Range("F10:I17")
'
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 174, 942, 252, 126).Select
With Selection
.Top = celda.Top
.Left = celda.Left
.Width = celda.Width
.Height = celda.Height
With .ShapeRange.Fill
.Visible = msoTrue
.UserPicture archivo
.TextureTile = msoFalse
.Transparency = 0.76
.RotateWithObject = msoTrue
End With
End With
End Sub
