Excel VBA Errors when trying to copy and paste objects from Excel to Word

Chris Tomz

New Member
Joined
Jul 22, 2020
Messages
3
Office Version
365, 2019
Platform
Windows
Hello All,

I have some VBA code that I need help refining. The problem I am having is inconsistent and unexplained errors, from my research it appears that the issue is with the clipboard crashing.

How the VBA code works:

I have an embedded Word documents with various bookmarks and reference texts. The bookmarks correspond to named ranges in the Excel workbook. My VBA code opens the embedded Word document, copies the various named ranges in the Excel workbook and pastes the content of the clipboard at the appropriate bookmark in the Word document.

I have a RUN ALL macro set up to create multiple word documents, but it crashes constantly during this process.

I’ve research how to fix this and may have found the answer (Do Loop to retry the copy/paste operation) but as I am very new to VBA I’m not sure how to implement it into my code.

Would greatly appreciate any help with this.


Here is my VBA code:

VBA Code:
Sub Full_policy_document()

    Dim wdApp       As Word.Application
    Dim Wks         As Excel.Worksheet
    Dim wddoc       As Word.Document

    Set Wks = ActiveSheet

    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False

    Set wddoc = wdApp.Documents.Open(Environ("UserProfile") & "\Google Drive\SMS TEMPLATES\01 POLICIES\001 H&S Full Policy Document.docx")

    Call ReplaceWords2(wddoc, Wks, False)
    Call CopyPasteImage2(wddoc, Wks, False) 'switch back to true
    wdApp.Quit
    

    Set wddoc = Nothing
    Set wdApp = Nothing

End Sub



Sub ReplaceWords2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

    Dim wdRng       As Word.Range
    Dim varTxt      As Variant
    Dim varRngAddress As Variant
    Dim i           As Long

varTxt = Split("cp1,na1,po2,id1,rd1,bd1,an1,ns1,ct1,bc1,pt1,vd1,me1,mc1,po1", ",")
    varRngAddress = Split("C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17", ",")

    For Each wdRng In oDoc.StoryRanges

        With wdRng.Find
            For i = 0 To UBound(varTxt)
                .Text = varTxt(i)
                .Replacement.Text = Wks.Range(varRngAddress(i)).Value
                .Wrap = wdFindContinue
                .Execute Replace:=wdReplaceAll
            Next i
        End With

    Next wdRng

    oDoc.SaveAs2 Environ("UserProfile") & "\desktop\001 H&S Full Policy Document"
    If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
    End If

End Sub



Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

    With oDoc
        .Activate

        .ActiveWindow.View = wdNormalView
        Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("CompanyLogo").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph

        Wks.Range("N11:O15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ConsulSig").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph
        
        Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ClientSig").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph
        
         Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        .Bookmarks("ClientSig2").Select
        .Parent.Selection.Paste
        .Parent.Selection.TypeParagraph

        .Save

        If boolCloseAfterExec Then
        oDoc.Close
        oDoc.Parent.Quit
        End If
        
    End With
End Sub

Here is the code I need help implementing.

VBA Code:
      On Error GoTo 0  ' Normal error handling
      Application.CutCopyMode = False   ' Clear clipboard before copy
      Range(excel_range_name).CopyPicture
      n = 1 ' Set counter to 1
      Do Until n > 3 'Attempt paste function three times before falling out
            If n < 3 Then  ' suspend normal error handling
                On Error Resume Next
            Else
                 On Error GoTo 0 ' on last attempt, reinstate normal error handling
            End If
            newWord.Bookmarks(bookmark_name).Range.Characters.Last.Paste   ' Paste into Word
            If Err.Number = 0 Then
                  On Error GoTo 0 'reinstate normal error handling
                  Exit Do   ' Exit if no error encountered
            End If
            n = n + 1  ' Increment counter and repeat the Do Until Loop
            DoEvents
      Loop
       On Error GoTo 0  ' Just to make sure that normal error handling is reinstated
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,714
Office Version
2016, 2010, 2007
Platform
Windows
Hi,

Try this version of CopyPasteImage2 code:
VBA Code:
Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)
  
  Const AttemptsMax = 10  ' Increase this constant if Error MsgBox appears
  Dim Attempt As Long
  
  With oDoc
    
    .Activate
    .ActiveWindow.View = wdNormalView
    
    Application.CutCopyMode = False
    
    On Error GoTo ErrHandler
    
    Attempt = 1
    Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("CompanyLogo").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    Attempt = 1
    Wks.Range("N11:O15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ConsulSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig2").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
  
    .Save
  
    If boolCloseAfterExec Then
      oDoc.Close
      oDoc.Parent.Quit
    End If
  
  End With
  
ErrHandler:
  
  If Attempt < AttemptsMax Then
    Attempt = Attempt + 1
    Application.CutCopyMode = False
    DoEvents
    DoEvents
    Resume  ' this returns execution of the errored line again
  Else
    MsgBox Err.Description, vbExclamation, "Error at Attempt = " & Attempt
  End If
  
End Sub
 

Chris Tomz

New Member
Joined
Jul 22, 2020
Messages
3
Office Version
365, 2019
Platform
Windows
Thanks Vladimir,

I tried the code below and even increased the constant as suggested (max 50) but the "resume without error" message keeps popping up and interrupting the run all function.

Any other ideas how to solve this issue?


Hi,

Try this version of CopyPasteImage2 code:
VBA Code:
Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)
 
  Const AttemptsMax = 10  ' Increase this constant if Error MsgBox appears
  Dim Attempt As Long
 
  With oDoc
   
    .Activate
    .ActiveWindow.View = wdNormalView
   
    Application.CutCopyMode = False
   
    On Error GoTo ErrHandler
   
    Attempt = 1
    Wks.Range("K2:L15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("CompanyLogo").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    Attempt = 1
    Wks.Range("N11:O15").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ConsulSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    Attempt = 1
    Wks.Range("N02:O07").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    .Bookmarks("ClientSig2").Select
    .Parent.Selection.Paste
    .Parent.Selection.TypeParagraph
    Application.CutCopyMode = False
    DoEvents
 
    .Save
 
    If boolCloseAfterExec Then
      oDoc.Close
      oDoc.Parent.Quit
    End If
 
  End With
 
ErrHandler:
 
  If Attempt < AttemptsMax Then
    Attempt = Attempt + 1
    Application.CutCopyMode = False
    DoEvents
    DoEvents
    Resume  ' this returns execution of the errored line again
  Else
    MsgBox Err.Description, vbExclamation, "Error at Attempt = " & Attempt
  End If
 
End Sub
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,714
Office Version
2016, 2010, 2007
Platform
Windows
Chris, this should work :)
Code:
Rich (BB code):
Option Explicit
'https://www.mrexcel.com/board/threads/.1140894/post-5528899

#If VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
  Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
#Else
  Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
  Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
  Private Declare Function CloseClipboard Lib "user32.dll" () As Long
#End If

Sub Full_policy_document()
  ' As is
End Sub

Sub ReplaceWords2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)
  ' As is
End Sub

Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

  Dim oWord As Word.Application

  On Error GoTo exit_
  Set oWord = oDoc.Application
  oWord.ScreenUpdating = False
  With oDoc
    Application.CutCopyMode = False
    If PictureToBookmark(Wks.Range("K2:L15"), .Bookmarks("CompanyLogo")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig2")) = False Then Exit Sub
    .Save
  End With

  If boolCloseAfterExec Then
    oDoc.Close
    oWord.Quit
    Set oDoc = Nothing
    Set oWord = Nothing
  End If

exit_:

  If Not oWord Is Nothing Then oWord.ScreenUpdating = True

  If Err Then
    MsgBox Err.Description, vbExclamation, "CopyPasteImage2 Error #" & Err.Number
  End If

End Sub

Function PictureToBookmark(oRng As Range, ByVal oBmk As Word.Bookmark) As Boolean
  Const TIMEOUT As Single = 0.1
  #If VBA7 Then
    Dim hMem As LongPtr
    Dim dwBytes As LongPtr
    Dim lpData As LongPtr
  #Else
    Dim hMem As Long
    Dim dwBytes As Long
    Dim lpData As Long
  #End If
  Dim t As Single
  Dim sBmkNm As String
  Dim oBmkRng As Word.Range

  On Error GoTo exit_
  sBmkNm = oBmk.Name
  Set oBmkRng = oBmk.Range

  ' Empty Clipboard
  Application.CutCopyMode = False
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    If OpenClipboard(0) <> 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't open Clipboard" & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Open Clipboard Error"
    Exit Function
  End If
  EmptyClipboard
  DoEvents
  CloseClipboard
  DoEvents

  ' Copy range as Picture
  On Error Resume Next
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    Err.Clear
    oRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    If Err.Number = 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't copy " & oRng.Address(0, 0) & " as Pictire." & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Copy Picture Error"
    Exit Function
  End If

  ' Paste Picture into Bookmark range
  oBmkRng.Paste
  oBmkRng.Parent.Bookmarks.Add sBmkNm, oBmkRng
  oBmkRng.InsertParagraph

  ' Return Ok
  PictureToBookmark = True

exit_:

  Application.CutCopyMode = False
  DoEvents

  Set oBmkRng = Nothing

  If Err Then
    MsgBox Err.Description, vbCritical, "PictureToBookmark Error #" & Err.Number
  End If

End Function
Regards
 
Last edited:

Chris Tomz

New Member
Joined
Jul 22, 2020
Messages
3
Office Version
365, 2019
Platform
Windows
Thanks Vladimir,

I implemented the code and it works great.

Experienced one error but it was much easier to resolve and continue the process.

Really appreciate the assistance :)

Chris, this should work :)
Code:
Rich (BB code):
Option Explicit
'https://www.mrexcel.com/board/threads/.1140894/post-5528899

#If VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
  Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As LongPtr
#Else
  Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
  Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
  Private Declare Function CloseClipboard Lib "user32.dll" () As Long
#End If

Sub Full_policy_document()
  ' As is
End Sub

Sub ReplaceWords2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)
  ' As is
End Sub

Sub CopyPasteImage2(oDoc As Word.Document, Wks As Excel.Worksheet, Optional boolCloseAfterExec As Boolean = True)

  Dim oWord As Word.Application

  On Error GoTo exit_
  Set oWord = oDoc.Application
  oWord.ScreenUpdating = False
  With oDoc
    Application.CutCopyMode = False
    If PictureToBookmark(Wks.Range("K2:L15"), .Bookmarks("CompanyLogo")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig")) = False Then Exit Sub
    If PictureToBookmark(Wks.Range("N02:O07"), .Bookmarks("ClientSig2")) = False Then Exit Sub
    .Save
  End With

  If boolCloseAfterExec Then
    oDoc.Close
    oWord.Quit
    Set oDoc = Nothing
    Set oWord = Nothing
  End If

exit_:

  If Not oWord Is Nothing Then oWord.ScreenUpdating = True

  If Err Then
    MsgBox Err.Description, vbExclamation, "CopyPasteImage2 Error #" & Err.Number
  End If

End Sub

Function PictureToBookmark(oRng As Range, ByVal oBmk As Word.Bookmark) As Boolean
  Const TIMEOUT As Single = 0.1
  #If VBA7 Then
    Dim hMem As LongPtr
    Dim dwBytes As LongPtr
    Dim lpData As LongPtr
  #Else
    Dim hMem As Long
    Dim dwBytes As Long
    Dim lpData As Long
  #End If
  Dim t As Single
  Dim sBmkNm As String
  Dim oBmkRng As Word.Range

  On Error GoTo exit_
  sBmkNm = oBmk.Name
  Set oBmkRng = oBmk.Range

  ' Empty Clipboard
  Application.CutCopyMode = False
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    If OpenClipboard(0) <> 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't open Clipboard" & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Open Clipboard Error"
    Exit Function
  End If
  EmptyClipboard
  DoEvents
  CloseClipboard
  DoEvents

  ' Copy range as Picture
  On Error Resume Next
  t = Timer + TIMEOUT
  While Timer <= t
    DoEvents
    Err.Clear
    oRng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    If Err.Number = 0 Then t = 0
  Wend
  If t <> 0 Then
    MsgBox "Can't copy " & oRng.Address(0, 0) & " as Pictire." & vbLf _
            & "Try hitting Win-V and clean a Clipboard buffer", _
            vbCritical, "Copy Picture Error"
    Exit Function
  End If

  ' Paste Picture into Bookmark range
  oBmkRng.Paste
  oBmkRng.Parent.Bookmarks.Add sBmkNm, oBmkRng
  oBmkRng.InsertParagraph

  ' Return Ok
  PictureToBookmark = True

exit_:

  Application.CutCopyMode = False
  DoEvents

  Set oBmkRng = Nothing

  If Err Then
    MsgBox Err.Description, vbCritical, "PictureToBookmark Error #" & Err.Number
  End If

End Function
Regards
 

ZVI

MrExcel MVP
Joined
Apr 9, 2008
Messages
3,714
Office Version
2016, 2010, 2007
Platform
Windows
Chris, thank you for confirming it works for you!
🍻:)
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,930
Messages
5,508,172
Members
408,669
Latest member
AgsikapAko

This Week's Hot Topics

Top