Exportar rango variable desde Excel a JPEG
He creado una hoja de Excel para poder realizar un calendario y una plantilla de personal mensualmente e introducir las modificaciones sobre los mismos y me gustaría poder exportar el calendario y la plantilla de personal en un JPEG para incluirlo en la intranet.
La necesidad que tengo es poder crear con VBA la posibilidad de exportarlo previa selección del rango a exportar como imagen, la selección del rango es para poder realizar una sola programación en lugar de una por cada Hoja.
Public Sub GuardarImagen()
Dim choObj As ChartObject, chGráf As Chart, ptImagen As Object
Dim blnGuardado As Boolean
Worksheets("Hoja1").Range("A1:I26").CopyPicture appearance:=xlScreen, Format:=xlPicture
Set choObj = ActiveSheet.ChartObjects.Add(0, 0, 800, 600)
Set chGráf = choObj.Chart
choObj.Activate
chGráf.ChartArea.Select
chGráf.Paste
Set ptImagen = chGráf.Pictures(1)
ptImagen.Left = 0
ptImagen.Top = 0
choObj.Border.LineStyle = xlNone
choObj.Width = ptImagen.Width + 7
choObj.Height = ptImagen.Height + 7
blnGuardado = chGráf.Export(Filename:="C:\borrar\ImagenExcel.JPG", filtername:="JPG")
If Not blnGuardado Then MsgBox prompt:="Problemas al guardar la imagen.", Buttons:=vbOKOnly + vbExclamation
choObj.Delete
Set choObj = Nothing
Set chGráf = Nothing
Set ptImagen = Nothing
End SubEste código guarda el rango A1:I26 de Hoja1 en c:\borrar\ con el nombre ImagenExcel.JPG
Saludos_
1 respuesta más de otro experto
Te anexo un ejemplo para exportar un rango a imagen jpeg
Cambia A1:F18 por el rango de celdas que quieras exportar.
Cambia "temp.jpeg" por el nombre de archivo que quieras ponerle al archivo con la imagen.
El archivo se guardará en la misma carpeta donde tienes el archivo con la macro.
Sub CopiarCeldasComoImagen()
'Por.Dante Amor
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets.Add
ruta = ThisWorkbook.Path & "\"
archivo = "temp.jpeg"
'
rango = "A1:F18"
'
With h1.Range(rango)
anc = .Width
alt = .Height
.CopyPicture
End With
'
h2.Shapes.AddChart
With h2.ChartObjects(1)
.Width = anc
.Height = alt
.Chart.Paste
.Chart.Export archivo
.Delete
End With
h2.Delete
Application.DisplayAlerts = True
'
MsgBox "Rango de celdas guardadas como imagen"
End Sub