如何将所有 InlineShapes 从 Word 复制到 Excel？

Question

我正在尝试将所有内联形状从 word 文档复制到 excel sheet。 Word 文档有多个页面，其中有多个 table 包含图像。我使用的代码是：

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.docx")


For Each shpCurr In wrdDoc.InlineShapes
    shpCurr.Range.CopyAsPicture
    Sheet10.Range("A" & i).PasteSpecial
    i = i + 1
Next shpCurr

End Sub

谁能给我解释一下为什么它对 Word 文档第一页的所有形状都有效，而对其他页面的形状不起作用？

wrdDoc.InlineShapes.Count shows the real number of the shapes in the doc, so the loop is compleate

在 .CopyAsImage 之前，我尝试将每个形状剪切并粘贴到第一页，但没有成功。

我还尝试遍历每个 table 并引用 table 的内联形状（“wrdDoc.tbl.InlineShapes”），但没有成功。

如果我手动将图片从（假设）第 2 页移动到第 1 页并再次运行代码，则会复制此图片。

Answer 1

如果问题不是变量 i 的初始设置，正如我在上面的评论中提到的，那么也许您应该尝试此代码，因为并非 Word 文档中的所有形状都必须是 InlineShapes。 InlineShapes 在 Word 中的定义是它们位于自己的段落中。 Word 文档中形状的另一种可能性是它们具有环绕文本并锚定到文档中的某个其他位置。 InlineShapes 和 Floating Shapes 的意义在于它们各自必须单独引用。

当然，您已经提到 InlineShapes 计数符合您的预期，但是......谁知道呢......也许试试这个：

    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.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

更新

在你把文件发给我之后，我发现问题出在 Excel 的 PasteSpecial 上，如果执行了太多次，范围 class 的错误 1004 PasteSpecial 方法失败了，因为由于某些未知原因，某些东西清除了剪贴板并尝试粘贴空剪贴板会产生错误。

我更改了您的代码以使用 Word 的选择方法复制图像，而不是原始代码中的 Range 方法并解决了问题……很奇怪但它有效。我还添加了一些其他代码，以便在例程结束时正确关闭 Word。

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 & ".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

如何将所有 InlineShapes 从 Word 复制到 Excel？

How to Copy ALL InlineShapes from Word to Excel?

excel

vba

copy

ms-word

image