VBA Error 1004 - CopyPicture method of Range class failed

[Jasesair]

I'm randomly experiencing this error "VBA Error 1004 - CopyPicture method of Range class failed" when trying to copy ranges into MS Word header and footer. The error is showing where I have bolded. I'm at a loss to know why this is happening - it's very random. It's run sometimes and not others. Big ask, but any help would be very much appreciated.

Sub CreateMarkingGuide5() 'UPDATE

Application.ScreenUpdating = False
Sheets("Marking Guides (2)").Visible = True

Call CopyPasteMGuide_Y3U5 'UPDATE
Call ExcelRangeToWordv25 'UPDATE

Sheets("Marking Guides (2)").Visible = False

End Sub

Sub FilterOutBlanks5() 'UPDATE

ActiveWorkbook.Sheets("Marking Guides (2)").Range("Y3U5").AutoFilter Field:=(46), Criteria1:="<>" 'UPDATE

End Sub
Sub CopyPasteMGuide_Y3U5() 'UPDATE

ThisWorkbook.Worksheets("Marking Guides (2)").Select
Range("at9:bb25").ClearContents 'UPDATE

Call FilterOutBlanks5 'UPDATE

Range("at35:bb52").Copy 'UPDATE
Range("at9").PasteSpecial Paste:=xlPasteValues 'UPDATE
Range("as9:as25").EntireRow.AutoFit 'UPDATE

Range("Y3U5").AutoFilter Field:=(46) 'UPDATE
Range("av9:av25").ClearContents 'UPDATE



End Sub
Sub ExcelRangeToWordv25() 'UPDATE

Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table

'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
  Set tbl = ThisWorkbook.Worksheets("Marking Guides (2)").Range("at9:bb25").SpecialCells(xlCellTypeConstants, 3) 'UPDATE
  Set Header = ThisWorkbook.Worksheets("Marking Guides (2)").Range("at1:bb7") 'UPDATE
  Set Footer = ThisWorkbook.Worksheets("Marking Guides (2)").Range("at27:bb28") 'UPDATE
  Set Sheet = ThisWorkbook.Worksheets("Marking Guides (2)")
'If MS Word is already open
 ' Set WordApp = GetObject("Word.Application")

'If MS Word is not already open then open MS Word
  If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")

'Make MS Word Visible and Active
  WordApp.Visible = True
 

'Create a New Document
  Set myDoc = WordApp.Documents.Add

'Copy Header range
  Sheet.Select
  Header.Select
  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'Copy Footer range
  Sheet.Select
  Footer.Select
[B]  Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture[/B]


'Set Word Margins
 With WordApp.ActiveDocument.PageSetup
 .Orientation = wdOrientLandscape
 .TopMargin = CentimetersToPoints(0.5)
 .BottomMargin = CentimetersToPoints(1)
 .LeftMargin = CentimetersToPoints(1)
 .RightMargin = CentimetersToPoints(1)
  End With
  
   
 'Change the view to header & footer
If WordApp.ActiveWindow.View.SplitSpecial <> wdPaneNone Then
WordApp.ActiveWindow.Panes(2).Close
End If

'Select the Header range and paste as image
ThisWorkbook.Worksheets("Marking Guides (2)").Range("at1:bb7").Copy 'UPDATE
WordApp.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False

'Select the Footer range and paste as image
ThisWorkbook.Worksheets("Marking Guides (2)").Range("at27:bb28").Copy 'UPDATE
WordApp.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteEnhancedMetafile, _
        Placement:=wdInLine, DisplayAsIcon:=False

WordApp.ActiveWindow.View.Type = wdNormalView
WordApp.ActiveWindow.View.Type = wdPrintView


  'Copy Excel Table range
  Sheet.Select
  tbl.Copy
 
'Paste Table into Word
myDoc.Content.Paste



'Autofit Table so it fits inside Word Document
 Set WordTable = myDoc.Tables(1)
 WordTable.AutoFitBehavior (wdAutoFitWindow)
 WordTable.RightPadding = CentimetersToPoints(0.2)
 
 Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False
  
  ThisWorkbook.Worksheets("Class Setup").Select
 
   WordApp.Activate


End Sub

 

[Jaafar Tribak]

This appears to be a bug but since it happens even when the screen is not locked.
Fortunately, since this error is trappable and only happens rarely and randomly, you can use a workaround :

1- Add this SUB to your project :

Sub RangeCopyPic(ByVal Rng As Range, ByVal Appearance As XlPictureAppearance, ByVal Format As XlCopyPictureFormat)

    On Error Resume Next
    Do
        Err.Clear
        Rng.CopyPicture Appearance:=Appearance, Format:=Format
        DoEvents
    Loop Until Err.Number = 0

End Sub

2- and then in your code, replace your call to the CopyPicture Method :

Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture

With this :

RangeCopyPic Rng:=Selection, Appearance:=xlScreen, Format:=xlPicture

 

[Jasesair]

Thanks so much for this. After much back and forth, I've made the call to go with a different option to the CopyPicture...to completely be rid of the error in the code. Appreciate your efforts.