Copy whole sheet to clipboard as picture when sheet protected

[MarkieVBA]

Hi,

I have some simple code to copy a sheet (an invoice form) as a picture to the clipboard for pasting into Outlook emails through a command button:

Sub ButtonCopy()
ActiveSheet.Range("A1:DG182").CopyPicture xlScreen, Format:=xlPicture
ActiveSheet.Paste
Selection.Width = 500
Selection.Height = 500
Selection.Copy
Selection.Delete
MsgBox "Invoice copied to clipboard." & vbNewLine & "" & vbNewLine & "Please paste (Rt Click or CTRL+V) in your existing email (with documents attached) from the supplier/office"
End Sub

It works exactly how I want it BUT only if the 'edit objects' option of the Protect Sheet function is unticked (which leaves the command buttons editable and a backdoor to the VBA which is bad news).

When ticked and fully protected it produces runtime error 1004 .. 'cannot paste the data' and the debugger highlights the 'ActiveSheet.Paste' line.

I've seen similar examples online but they all seem to deal with pasting the sheet into another sheet which doesn't help. I also tried using 'On Error Resume Next' and 'Application.CutCopyMode = False' which did allow me to fully protect the sheet without the 1004, but it only copied the currently highlighted box as a picture.

I feel the solution is close, but I've run out of ideas. Can anyone please help?

Many thanks in advance.

 

[GWteB]

I've seen similar examples online but they all seem to deal with pasting the sheet into another sheet which doesn't help.

Have you considered using a temporary worksheet? After all, you can easily remove it afterwards, like this:

Sub ButtonCopy()

    ActiveSheet.Range("A1:DG182").CopyPicture xlScreen, Format:=xlPicture

    Application.ScreenUpdating = False
    With Workbooks.Add.ActiveSheet
        .Paste
        With .Shapes(1)
            .Width = 500
            .Height = 500
            .Copy
        End With
        .Parent.Close SaveChanges:=False
    End With
    Application.ScreenUpdating = True

    MsgBox "Invoice copied to clipboard." & vbNewLine & "" & vbNewLine & "Please paste (Rt Click or CTRL+V) in your existing email (with documents attached) from the supplier/office"
End Sub

 

[MarkieVBA]

That works perfectly!

Awesome, thanks

 

[GWteB]

Glad to help and welcome to this board!

 

[MarkieVBA]

Thanks again. I was wondering if this method could be expanded to copy 2 sheets and merge them (side by side or up and down shouldn't matter) in the clipboard?

I tried:

Worksheets("Sheet1").Range("A1:DG182").CopyPicture xlScreen, Format:=xlPicture
Worksheets("Sheet2").Range("A1:DG182").CopyPicture xlScreen, Format:=xlPicture

and also placing this 2nd line before the parent.close and repeating the With & End With section but neither worked.

Then I tried a union merging:

Sub ButtonCopy()
Dim range1 As Range, range2 As Range, multiplerange As Range
    Set range1 = Sheets("Sheet1").Range("A1:DG182")
    Set range2 = Sheets("Sheet2").Range("A1:DG182")
    Set multiplerange = Union(range1, range2)
    multiplerange.CopyPicture xlScreen, Format:=xlPicture
    Application.ScreenUpdating = False
    With Workbooks.Add.ActiveSheet
        .Paste
        With .Shapes(1)
            .Width = 500
            .Height = 500
            .Copy
        End With
        .Parent.Close SaveChanges:=False
        End With
Application.ScreenUpdating = True
MsgBox "Invoices copied to clipboard." & vbNewLine & "" & vbNewLine & "Please paste (Rt Click or CTRL+V) in your existing email (with documents attached) from the supplier/office"
End Sub

But this just produces a subscript error 9.