Buenas tardes,

Tengo un documento, con un fondo, como imagen, y quisiera crear un botón para hacer una captura de pantalla para poder imprimirla al paint. 

Quisiera saber si es posible crear un botón, que me haga una captura de pantalla y que luego la pueda pegar al paint e imprimirla, y si se puede que con el botón lo haga todo mejor.

He probado con el siguiente código, pero el fondo no me lo imprime, y con una marca de agua el tamaño de la imagen no me aclaro mucho

Private Sub Image1_Click()
ActiveSheet.PageSetup.PrintArea = ActiveWindow.VisibleRange.Address
ActiveSheet.PrintPreview
End Sub

Muchas gracias.

Un saludo

Buenas @dbuera

Para realizar copiado de toda la pantalla utiliza

Application.SendKeys "{1068}"

Un saludo

Muchas gracias @logroastur, sabes si hay algun tipo de macro para imprimir lo que se ve en pantalla sin pasar por el programa "paint"? 

 

Muchas gracias

Buenas @dbuera

Esa es, lo que realiza es copiar la pantalla, lo único que debes de realizar es colocar en una Hoja, Shape o Gráfico los copiado y luego dar a imprimir.donde has colocado lo copiado.

es decir

' USANDO UN GRAFICO
Sub PrintScreenChart()
    Dim tempe As Double
    ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ThisWorkbook.Charts.Add
    ThisWorkbook.Charts(ThisWorkbook.Charts.Count).Name = "pChartScreen"
    ThisWorkbook.Charts(ThisWorkbook.Charts.Count).Location Where:=xlLocationAsObject, Name:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.ChartArea.Width = Application.UsableWidth
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.ChartArea.Height = (Application.UsableHeight * 0.4) + Application.UsableHeight
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.Parent.Border.LineStyle = 0
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.ChartArea.Format.Line.Visible = False
    Application.CutCopyMode = False
    Application.SendKeys "{1068}"
    tempe = Timer + 2
    Do While Timer < tempe
        DoEvents
    Loop
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.ChartArea.Select
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.Paste
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects(ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).ChartObjects.Count).Chart.PrintOut
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Delete
End Sub
                          
' USANDO UNA HOJA
Sub PrintScreenSheets()
    Dim tempe As Double
    ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        With .PageSetup
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .Orientation = xlLandscape
        End With
    End With
    Application.CutCopyMode = False
    Application.SendKeys "{1068}"
    tempe = Timer + 2
    Do While Timer < tempe
        DoEvents
    Loop
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Range("A1").PasteSpecial
    Application.CutCopyMode = False
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).PrintOut
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Delete
End Sub

Un saludo

Lo has bordado @logroastur, 

Me has sacado de un apuro,

Muchas gracias

Un saludo

 

Tema finalizado

Hola de nuevo @logroastur, he estado usando tu macro pero me ha dejado de funcionar, y no se porque. Lo que me hace ahora és en la pagina que tengo la macro me crea otra al lado y me la imprime. la macro que uso es la siguiente: 

Private Sub Image1_Click()
 Dim tempe As Double
    ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        With .PageSetup
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .Orientation = xlLandscape
        End With
    End With
    Application.CutCopyMode = False
    Application.SendKeys "{1068}"
    tempe = Timer + 2
    Do While Timer < tempe
        DoEvents
    Loop
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Range("A1").PasteSpecial
    Application.CutCopyMode = False
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).PrintOut
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Delete
End Sub

A que puede ser debido? Se puede imprimir directamente sin abrir otra página?

 

Muchas grácias de nuevo. 

un saludo