Copy only visible cells in screenshot

[andrewb90]

Hello all,

I have a code that get a current screenshot and the pastes and centers in on the current screen, however, what I am trying to do is only get a screenshot of the cells and the grid. Not the headings,ribbon, excel bar, start menu, etc.

In other words, if I can see cells A1:R20 in my current view of the screen. When I do my screenshot, it would copy the image of those cells only and when it was pasted and centered it would be an identical picture of my current view. (You wouldn't know it was a picture until you clicked on it)

Sub CopyScreen()


Application.SendKeys "({1068})", True
DoEvents
ActiveSheet.Paste


Dim shp As Shape
With ActiveSheet
    Set shp = .Shapes(.Shapes.Count)
End With
Selection.Name = "screen01"
    Dim myPicture As Shape
     
    Set myPicture = ActiveSheet.Shapes("screen01")
     
    With ActiveWindow.VisibleRange
        myPicture.Top = .Top + .Height / 2 - myPicture.Height / 2
        myPicture.Left = .Left + .Width / 2 - myPicture.Width / 2
    End With
    myPicture.Visible = True


End Sub

Any help would be greatly appreciated. (I hope I made my goal clear, btw)

 

[Rick Rothstein]

Update: On a single pane sheet, I have it solved:

It took awhile for me to work it out, but the following macro (it replaces what I gave you earlier) will handle any frozen window arrangement as well as an unfrozen window. I wasn't sure where you were copying the pictures to, so I guessed at a sheet named "Home". If that was wrong, change the red highlighted text to the correct sheet name.

[table="width: 500"]
[tr]
	[td]Sub PutPictureOfPaneOverPane()
  Dim X As Long, PaneCount As Long
  PaneCount = ActiveWindow.Panes.Count
  For X = 1 To PaneCount
    With ActiveWindow.Panes(X)
      .VisibleRange.Select
      .VisibleRange.CopyPicture xlScreen, xlBitmap
      ActiveSheet.Pictures.Paste.Select
      Selection.Name = "Pane" & X
    End With
  Next
  With Sheets("[B][COLOR="#FF0000"]Home[/COLOR][/B]")
    For X = 1 To PaneCount
      ActiveSheet.Shapes("Pane" & X).Cut
      .Paste
    Next
    For X = 1 To PaneCount
      .Shapes("Pane1").Top = 0
      .Shapes("Pane1").Left = 0
      If PaneCount = 2 Then
        If .Shapes("Pane1").Width = .Shapes("Pane2").Width Then
          .Shapes("Pane2").Top = .Shapes("Pane1").Top + .Shapes("Pane1").Height
          .Shapes("Pane2").Left = .Shapes("Pane1").Left
        Else
          .Shapes("Pane2").Top = .Shapes("Pane1").Top
          .Shapes("Pane2").Left = .Shapes("Pane1").Left + .Shapes("Pane1").Width
        End If
      ElseIf PaneCount = 4 Then
        .Shapes("Pane2").Top = .Shapes("Pane1").Top
        .Shapes("Pane2").Left = .Shapes("Pane1").Left + .Shapes("Pane1").Width
        .Shapes("Pane3").Top = .Shapes("Pane1").Top + .Shapes("Pane1").Height
        .Shapes("Pane3").Left = .Shapes("Pane1").Left
        .Shapes("Pane4").Top = .Shapes("Pane1").Top + .Shapes("Pane1").Height
        .Shapes("Pane4").Left = .Shapes("Pane1").Left + .Shapes("Pane1").Width
      End If
      .Shapes("Pane1").Select
    Next
  End With
  Range("A1").Select
End Sub[/td]
[/tr]
[/table]

 

[andrewb90]

Very impressive! It works perfectly. I'm going to add this to the rest of my sequence, and hopefully this will be complete. Thank you very much!