How to Copy ALL InlineShapes from Word to Excel? - excel

Question

I'm trying to copy all inline shapes from a word document to excel sheet.
The Word Document has multiple pages, with multiple tables with images in them.
The code I'm using is:
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim shpCurr As InlineShape
Dim i As Long
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("C:\Temp\01.docx")
For Each shpCurr In wrdDoc.InlineShapes
shpCurr.Range.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial
i = i + 1
Next shpCurr
End Sub
Can someone explain to me why it is working for all the shapes in the first page of the Word document, and doesn't work for the shapes from another pages?
wrdDoc.InlineShapes.Count shows the real number of the shapes in the doc, so the loop is compleate
I've tried to cut and paste each shape to the first page before .CopyAsImage, with no sucsess.
I also tried to loop through each table and reference to the table's inline shapes ( "wrdDoc.tbl.InlineShapes"), with no sucsess.
If I manualy move a picture from (let's say) Page2 to Page1 and run the code again, this picture is copied.

Answer 1

If the problem is not the initial setting of the variable i, as I have mentioned in my comment above, then maybe you should try this code because not all shapes in a Word document are necessarily InlineShapes. The definition of InlineShapes in Word is they reside on their own paragraph. The other possibility for Shapes in a Word document are they have wrapping text and are anchored to some other place in the document. The significance here for InlineShapes and Floating Shapes is they each have to be referenced separately.
Of course you have mentioned that the InlineShapes count matches to what you expect but ... who knows ... maybe try this:
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim iShp As Word.InlineShape, shp As Word.Shape
Dim i As Long
Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("C:\Temp\01.docx")
If wrdDoc.Shapes.Count > 0 Then
For i = 1 To wrdDoc.Shapes.Count
Set shp = wrdDoc.Shapes(i)
shp.ConvertToInlineShape
Next
End If
If wrdDoc.InlineShapes.Count > 0 Then
For i = 1 To wrdDoc.InlineShapes.Count
Set iShp = wrdDoc.InlineShapes(i)
iShp.Range.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial
Next
End If
End Sub
UPDATE
After you sent me the files I was able to figure out that the problem is with Excel's PasteSpecial and if executed too many times an error 1004 PasteSpecial method of Range class failed because for some unknown reason something clears the clipboard and attempting to paste an empty clipboard generates the error.
I altered your code to use Word's Selection method to copy the images versus a Range method that was in your original code and that took care of the problem ... strange but it works. I also added some other code so that Word is properly closed out when the routine ends.
Sub imageExtract()
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim shpCurr As Word.InlineShape
Dim i As Long
On Error GoTo errHandler
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(ThisWorkbook.Path & "\01.docx")
i = 1
wrdDoc.Activate
Debug.Print wrdDoc.InlineShapes.Count
'On Error Resume Next
For Each shpCurr In wrdDoc.InlineShapes
shpCurr.Select
wrdApp.Selection.CopyAsPicture
Sheet10.Range("A" & i).PasteSpecial xlPasteAll
i = i + 1
Next
'the following is copying only one character which will clear the clipboard
'and prevent the message about wanting to save the last thing copied
wrdApp.Selection.EndKey wdStory
wrdApp.Selection.MoveStart wdCharacter, -1
wrdApp.Selection.Copy
wrdDoc.Close SaveChanges:=wdDoNotSaveChanges
Set wrdDoc = Nothing
wrdApp.Quit
Set wrdApp = Nothing
MsgBox "Complete"
Exit Sub
errHandler:
MsgBox Err.Number & Chr(32) & Err.Description, vbCritical
wrdDoc.Close SaveChanges:=wdDoNotSaveChanges
wrdApp.Quit
Set wrdApp = Nothing
End Sub