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)

 

[Fluff]

How about

Sub ShtPic()
    Range("A1:R20").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    ActiveSheet.Pictures.Paste.Select
End Sub

 

[andrewb90]

That kind of works. it did capture only cells, but since there are frozen rows it only captured the frozen rows and not what was viewable on the entire screen.

 

[Rick Rothstein]

That kind of works. it did capture only cells, but since there are frozen rows it only captured the frozen rows and not what was viewable on the entire screen.

Does it have to be a single picture? Because you have frozen cells, you have multiple Panes, each one is its own mini-window. We can use Fluff's concept as a base in order to take a picture of each Pane and paste that picture over top of the Pane it captured. Depending on how you froze the screen, you will have either two or four Panes (if the screen is unfrozen, then there is only one Pane). Here is the code to put a picture of each Pane over top of the Pane it is a picture of...

Sub PutPictureOfPaneOverPane()
  Dim P As Long
  For P = 1 To ActiveWindow.Panes.Count
    With ActiveWindow.Panes(P)
      .VisibleRange.Select
      .VisibleRange.CopyPicture xlScreen, xlBitmap
      ActiveSheet.Pictures.Paste.Select
    End With
  Next
End Sub

 

[andrewb90]

Hat's off to your sir! that's really cool! Thank you!

 

[andrewb90]

Also, anyway to figure out how to name each picture, so that I can cut and paste them onto a different sheet? Or some variation? Basically, once I get the screen capture, I am placing the picture(s) onto a different sheet.

 

[Rick Rothstein]

Also, anyway to figure out how to name each picture, so that I can cut and paste them onto a different sheet? Or some variation? Basically, once I get the screen capture, I am placing the picture(s) onto a different sheet.

This should name them Pane# where # is the number of the pane. So if you did a simple row split or simple column split, then they should be named Pane1 and Pane2. If you did a multiple split (by column and row), then there should be a Pane3 and Pane4 as well.

Sub PutPictureOfPaneOverPane()
  Dim X As Long, Sh As Shape, Obj As Object
  For X = 1 To ActiveWindow.Panes.Count
    With ActiveWindow.Panes(X)
      .VisibleRange.Select
      .VisibleRange.CopyPicture xlScreen, xlBitmap
      ActiveSheet.Pictures.Paste.Select
      Selection.Name = "Pane" & X
    End With
  Next
End Sub

 

[andrewb90]

awesome thank you. Ill test this out later today.

 

[andrewb90]

So I modified the code to place the pictures on my selected page, but I can't get them to lineup where I want them. which would be placed identical to where they would sit on the active sheet.

Sub PutPictureOfPaneOverPane()
Application.Run "module5.destructure"
Sheets("Home").Visible = True
  Dim P As Long
  For P = 1 To ActiveWindow.Panes.Count
    With ActiveWindow.Panes(P)
      .VisibleRange.Select
      .VisibleRange.CopyPicture xlScreen, xlBitmap
      Sheets("Home").Pictures.Paste.Select
      'Range("A13").Select
      'ActiveSheet.Pictures.Paste.Select
    End With
  Next
End Sub

 

[andrewb90]

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

Sub PutPictureOfPaneOverPane()Application.Run "module5.destructure"
zStartSheet = ActiveSheet.Name
Sheets("Home").Visible = True
Sheets("Home").Select
Range("A1").Select
Worksheets(zStartSheet).Select
ActiveSheet.Range("A1").Select
  Dim X As Long, Sh As Shape, obj As Object
  For X = 1 To ActiveWindow.Panes.Count
    With ActiveWindow.Panes(X)
        .VisibleRange.Select
        .VisibleRange.CopyPicture xlScreen, xlBitmap
        Sheets("Home").Pictures.Paste.Select
        


     ' ActiveSheet.Pictures.Paste.Select
      'Selection.Name = "Pane" & X
      'Selection.copy
      'Sheets("Home").Pictures.Paste.Select
      
    End With
    Sheets("Home").Select
        With Selection
            .Name = "Pane" & X
        End With
  Next
End Sub

My issue is now with a sheet that has frozen cells.
I get error: "Method 'visibleRange' of object 'Pane' failed