Error 1004 - Can't Copy as Picture, but only on certain computer

[MrPoindexter]

This is breaking my head, and I don't get it. I have a project that is using a very large excel spreadsheet to update content controls in Word. Part of the project selects large ranges in excel and copies them as pictures. I have ran the VBA on 9 different computers, and it works perfectly. Two colleagues keep getting the same 1004 error. "CopyPicture method of Range class failed". They are both running with multiple displays. I've tested it with and without displays, works fine. One colleague is using an HP Pavilion, Windows 11 Home version. BIOS F.04 November 2023. All windows updates are in. Fails. I bought the identical computer, except it has BIOS F.03 August of 2023. Works fine. I've tried just about everything you can think of, and I am at my wits end. Need help. Here is a sample of the code:

Sub M12BDF()
Dim cc As Object
Dim ws As Worksheet
Dim excelRanges() As Range
Dim contentControlTitles() As String
Dim i As Integer
Dim foundImage As Boolean
Dim founText As Boolean
Dim wb As Workbook

' Check if the target workbook has been set
If targetWorkbook Is Nothing Then
MsgBox "No target workbook selected. Please select a workbook first.", vbCritical
Exit Sub
End If

' Check if a Word document has been selected
If SelectedWordDoc Is Nothing Then
MsgBox "No Word document selected. Please reopen the Excel workbook and select a document.", vbCritical
Exit Sub
End If

' Excel part: Define the ranges to be copied as pictures
Set wb = targetWorkbook
Set ws = targetWorkbook.Sheets("Buildings")
ReDim excelRanges(2)
Set excelRanges(0) = ws.Range("B2:Q19")
Set excelRanges(1) = ws.Range("W2:AK19")
Set excelRanges(2) = ws.Range("C23:J37")

' Assigning titles to the array
ReDim contentControlTitles(2)

' Assigning titles to the array, one per line
contentControlTitles(0) = "cvas_dt_building_inventory"
contentControlTitles(1) = "cvas_dt_building_RCN"
contentControlTitles(2) = "cvas_dt_Site_ImpRCN1"

' Loop through the arrays to copy each Excel range and paste it into the corresponding Content Control in Word
wb.Activate
ws.Activate


For i = LBound(excelRanges) To UBound(excelRanges)
' Scroll the range into view
ws.Activate
Application.GoTo Reference:=excelRanges(i), Scroll:=True


On Error Resume Next ' Start error handling
excelRanges(i).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Application.CutCopyMode = False ' Exit cut/copy mode to help clear clipboard
' Check if the CopyPicture method succeeded
If Err.Number = 0 Then
For Each cc In SelectedWordDoc.ContentControls
If cc.Title = contentControlTitles(i) Then
cc.Range.Delete
' Attempt to paste and check for errors
On Error Resume Next
cc.Range.Paste
If Err.Number = 0 Then
foundImage = True
Else
MsgBox "Error pasting picture: " & Err.Description
' Handle paste error, e.g., try again or log error
End If
On Error GoTo 0 ' Stop error handling for paste
End If
Next cc
Else
MsgBox "Error copying picture: " & Err.Description
' Handle copy error, e.g., try again or log error
End If
On Error GoTo 0 ' Stop error handling for copy
Next i

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

' Message indicating completion and whether updates were made
If Not SuppressMessages Then
If foundImage Or foundText Then
MsgBox "DocuFaze Successful", vbInformation
Else
MsgBox "No specified Content Controls were found in the active Word document.", vbExclamation
End If
End If
' Cleanup
Set ws = Nothing
Set wb = Nothing
End Sub


Note - I am using error handlers throughout.

 

[rlv01]

Which line of code produces the error?

(Tip: For future posts , please try to use code tags when posting code. It makes your code easier to read and copy.

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

)

 

[MrPoindexter]

Which line of code produces the error?

(Tip: For future posts , please try to use code tags when posting code. It makes your code easier to read and copy.

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

)

excelRanges(i).CopyPicture Appearance:=xlPrinter, Format:=xlPicture

 

[NdNoviceHlp]

Trial just...

excelRanges(i).Copy

Let XL decide how it want to copy. HTH. Dave

 

[MrPoindexter]

Trial just...

excelRanges(i).Copy

Let XL decide how it want to copy. HTH. Dave

That will not work. The range needs to be copied as a picture, or it looks really bad when the content controls are updated in Word.

 

[rlv01]

CopyPicture method of range class failed - sometimes

I have a VBA code which I am using to copy ranges as a picture and paste them into a chart. It does this so I can save it into a picture. This code has like a 70% success rate, and when it doesn't ...

stackoverflow.com

See the above. I think they are on the right track.

 

[NdNoviceHlp]

*mrPoindexter the solution I suggested did in fact resolve an ongoing sporadic past error of mine while performing the same copy range and paste to a Word document.... I didn't just dream it up. Application.CutCopyMode = False does not clear the clipboard. If you don't actually clear the clipboard, XL will randomly crash when copying and pasting pictures. You can trial placing the API's for clearing the clipboard in module code and then doing whatever with the rest of this code which works without error for copying XL ranges to Word documents (however I'm uncertain about copying to content controls). I've also added (and commented out) some code to allow XL to do it's thing after pasting... it sometimes helps. You can trial this if your sporadic errors re-occurs and it turns out to be a code processing timing error. Dave

'module code
#If VBA7 And Win64 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
#End If

'code somewhere
excelRanges(i).CopyPicture Appearance:=xlScreen, Format:=xlPicture
cc.Range.PasteSpecial DataType:=3
'Dim T As Double
'T = Timer
'Do Until Timer - T > 1
'  DoEvents
'Loop
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

ps. please use code tags

 

[MrPoindexter]

CopyPicture method of range class failed - sometimes

I have a VBA code which I am using to copy ranges as a picture and paste them into a chart. It does this so I can save it into a picture. This code has like a 70% success rate, and when it doesn't ...

stackoverflow.com

See the above. I think they are on the right track.

Thank you. I did go through this thread prior to posting my question. That thread seems to go in a million different directions, and I'm not sure where to start.

 

[MrPoindexter]

*mrPoindexter the solution I suggested did in fact resolve an ongoing sporadic past error of mine while performing the same copy range and paste to a Word document.... I didn't just dream it up. Application.CutCopyMode = False does not clear the clipboard. If you don't actually clear the clipboard, XL will randomly crash when copying and pasting pictures. You can trial placing the API's for clearing the clipboard in module code and then doing whatever with the rest of this code which works without error for copying XL ranges to Word documents (however I'm uncertain about copying to content controls). I've also added (and commented out) some code to allow XL to do it's thing after pasting... it sometimes helps. You can trial this if your sporadic errors re-occurs and it turns out to be a code processing timing error. Dave

'module code
#If VBA7 And Win64 Then
    Public Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Public Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
#Else
    Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function CloseClipboard Lib "user32" () As Long
    Public Declare Function EmptyClipboard Lib "user32" () As Long
#End If

'code somewhere
excelRanges(i).CopyPicture Appearance:=xlScreen, Format:=xlPicture
cc.Range.PasteSpecial DataType:=3
'Dim T As Double
'T = Timer
'Do Until Timer - T > 1
'  DoEvents
'Loop
Application.CutCopyMode = False
OpenClipboard (0&)
EmptyClipboard
CloseClipboard

ps. please use code tags

Thank you. I'm sorry, I'm not understanding. If I paste the code tags will you help me rewrite it? When I used the excelRanges(i).Copy by itself, it didn't work correctly going into word. It seems to need the full CopyPicture Appearance...

Sub M12BDF()
    Dim cc As Object
    Dim ws As Worksheet
    Dim excelRanges() As Range
    Dim contentControlTitles() As String
    Dim i As Integer
    Dim foundImage As Boolean
    Dim founText As Boolean
    Dim wb As Workbook

    ' Check if the target workbook has been set
    If targetWorkbook Is Nothing Then
        MsgBox "No target workbook selected. Please select a workbook first.", vbCritical
        Exit Sub
    End If
    
    ' Check if a Word document has been selected
    If SelectedWordDoc Is Nothing Then
        MsgBox "No Word document selected. Please reopen the Excel workbook and select a document.", vbCritical
        Exit Sub
    End If

    ' Excel part: Define the ranges to be copied as pictures
    Set wb = targetWorkbook
    Set ws = targetWorkbook.Sheets("Buildings")
    ReDim excelRanges(2)
    Set excelRanges(0) = ws.Range("B2:Q19")
    Set excelRanges(1) = ws.Range("W2:AK19")
    Set excelRanges(2) = ws.Range("C23:J37")
    
  ' Assigning titles to the array
   ReDim contentControlTitles(2)
    
    ' Assigning titles to the array, one per line
    contentControlTitles(0) = "building_inventory"
    contentControlTitles(1) = "building_RCN"
    contentControlTitles(2) = "Site_ImpRCN1"
    
    ' Loop through the arrays to copy each Excel range and paste it into the corresponding Content Control in Word
  wb.Activate
  ws.Activate


For i = LBound(excelRanges) To UBound(excelRanges)
     ' Scroll the range into view
    ws.Activate
    Application.GoTo Reference:=excelRanges(i), Scroll:=True
 
    
    On Error Resume Next ' Start error handling
    excelRanges(i).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    Application.CutCopyMode = False ' Exit cut/copy mode to help clear clipboard
    ' Check if the CopyPicture method succeeded
    If Err.Number = 0 Then
        For Each cc In SelectedWordDoc.ContentControls
            If cc.Title = contentControlTitles(i) Then
                cc.Range.Delete
                ' Attempt to paste and check for errors
                On Error Resume Next
                cc.Range.Paste
                If Err.Number = 0 Then
                    foundImage = True
                Else
                    MsgBox "Error pasting picture: " & Err.Description
                    ' Handle paste error, e.g., try again or log error
                End If
                On Error GoTo 0 ' Stop error handling for paste
            End If
        Next cc
    Else
        MsgBox "Error copying picture: " & Err.Description
        ' Handle copy error, e.g., try again or log error
    End If
    On Error GoTo 0 ' Stop error handling for copy
Next i
    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

    ' Message indicating completion and whether updates were made
   If Not SuppressMessages Then
    If foundImage Or foundText Then
        MsgBox "DocuFaze Successful", vbInformation
    Else
        MsgBox "No specified Content Controls were found in the active Word document.", vbExclamation
    End If
End If
    ' Cleanup
    Set ws = Nothing
    Set wb = Nothing
End Sub

 

[NdNoviceHlp]

Here's the expanded but condensed version. The previously posted clipboard code is module code and depending upon how often you run the sub, you may not need it. (However, It won' hurt having it.) Assuming that you have code that passes the "targetworkbook" and "SelectedWordDoc" as variables to the sub, this code seem like it should work. Good luck. Dave

Sub M12BDF()
    Dim cc As Object
    Dim ws As Worksheet
    Dim excelRanges() As Range
    Dim contentControlTitles() As String
    Dim i As Integer
    Dim foundImage As Boolean
    Dim founText As Boolean
    Dim wb As Workbook, Orng As Object

    ' Check if the target workbook has been set
    If targetWorkbook Is Nothing Then
        MsgBox "No target workbook selected. Please select a workbook first.", vbCritical
        Exit Sub
    End If
    
    ' Check if a Word document has been selected
    If SelectedWordDoc Is Nothing Then
        MsgBox "No Word document selected. Please reopen the Excel workbook and select a document.", vbCritical
        Exit Sub
    End If

    ' Excel part: Define the ranges to be copied as pictures
    Set wb = targetWorkbook
    Set ws = targetWorkbook.Sheets("Buildings")
    ReDim excelRanges(2)
    Set excelRanges(0) = ws.Range("B2:Q19")
    Set excelRanges(1) = ws.Range("W2:AK19")
    Set excelRanges(2) = ws.Range("C23:J37")
    
  ' Assigning titles to the array
   ReDim contentControlTitles(2)
    
    ' Assigning titles to the array, one per line
    contentControlTitles(0) = "building_inventory"
    contentControlTitles(1) = "building_RCN"
    contentControlTitles(2) = "Site_ImpRCN1"
    
    ' Loop through the arrays to copy each Excel range and paste it into the corresponding Content Control in Word
  wb.Activate'????

For i = LBound(excelRanges) To UBound(excelRanges)
     ' Scroll the range into view
    ws.Activate'?????
    Application.GoTo Reference:=excelRanges(i), Scroll:=True
    excelRanges(i).CopyPicture Appearance:=xlScreen, Format:=xlPicture
        For Each cc In SelectedWordDoc.ContentControls
            If cc.Title = contentControlTitles(i) Then
            cc.Range.Delete
            cc.Range.PasteSpecial DataType:=3

            'Dim T As Double
            'T = Timer
            'Do Until Timer - T > 1
            '  DoEvents
            'Loop
            Application.CutCopyMode = False
            OpenClipboard (0&)
            EmptyClipboard
            CloseClipboard
            Exit For
            End If
        Next cc
Next i
    
    ' Cleanup
    Set ws = Nothing
    Set wb = Nothing
End Sub