如何在word文档中选择形状并使用VBA将它们粘贴到另一个word文档中？答案

【问题标题】：How to select shapes in a word document and paste them in another word document using VBA?如何在word文档中选择形状并使用VBA将它们粘贴到另一个word文档中？
【发布时间】：2021-12-03 00:58:44
【问题描述】：

我只想将形状（形状是画布）从 Word 文档“A”的一部分复制到 Word 文档 B 的一部分。

我做了下一个代码：

Sub CopyInfo()
  Dim A_Path, Prop As String 'path of A,title
  Dim dlgSelectFile As FileDialog 'Object for selecting path
  'Create File dialog oject
  Set dlgSelectFile = Application.FileDialog(msoFileDialogFilePicker)
  With dlgSelectFile
  .Filters.Clear
  .AllowMultiSelect = False
  .Show
  A_Path = .SelectedItems(1) 'saving selected document
  End With

'Open ESI
Dim ADoc As Document
Set ADoc = Documents.Open(A_Path)

Dim MyRange As Range

'State Diagram
Documents(ADoc).Activate 'Activate A document
Set MyRange = ActiveDocument.Content
With ActiveDocument.Range
  With .Find 'find logical description heading
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Logical Description"
    .Style = "Heading 2"
    .Format = True
    .Forward = True
    .MatchCase = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Execute
  End With
  If .Find.Found = True Then
    Set MyRange = .Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel") 'set range of heading section
    MyRange.Start = MyRange.Paragraphs.First.Range.End
    MyRange.SetRange Start:=MyRange.Start, End:=MyRange.End - 1
        For i = 1 To MyRange.ShapeRange.Count 'search and copy/paste only images
            MyRange.ShapeRange.Item(MyRange.ShapeRange.Count + 1 - i).Select
            Selection.Copy
            ThisDocument.Activate 'Activate document B
            Selection.GoTo What:=wdGoToBookmark, Name:="StateDiagram" 'go to bookmark where i want to paste images
            Selection.PasteSpecial Placement:=wdInLine 'paste on document B
            Documents(ADoc).Activate 'Activate A document
        Next i
    End If
End With

End Sub

在我的代码中，我从文档“B”打开文档“A”，并在我想要从中获取形状的部分（这是标题中的内容）中设置 MyRange。然后对于 MyRange 中的所有形状，我将它们一个一个复制并粘贴到文档 B 中（从最后一个形状开始到第一个形状）。

问题是有时它会复制数字，有时则不会。我认为问题出在 selection.copy 中，因为它确实选择了形状，但剪贴板仍然是空的。有谁知道问题出在哪里？

注意：我不知道这是否有关系，但是当文档“A”已经打开并且我的光标位于最后一个形状下方时，它确实会复制它们。我已经在许多不同的“A”文档中尝试过，结果也是一样。

我是 VBA 的新手，如果我的问题的解决方案真的很明显或者我没有说清楚，我很抱歉。

【问题讨论】：

您是否从 Excel 运行此代码？如果是这样，Selection 指的是 Excel，而不是 Word。
Range.Select Selection.Copy 可以简化为Range.Copy。并将Selection.Paste 改进为Range.Paste。通过消除对Selection 的依赖，您可以提高代码的准确性和可靠性。例如ThisDocument.Range.Goto(What:=wdGoToBookmark, Name:="StateDiagram").PasteSpecial Placement:=wdInLine
@Toddleson - 除了Shape 或ShapeRange 没有Copy 方法。当然，如果源文档中的标题范围仅包含形状，那么targetRange.FormattedText = sourceRange.FormattedText 将起作用并避免使用剪贴板。
@TimothyRylatt 我正在使用 word 运行代码，选择对象是否不适用于 word？不幸的是，标题范围还包含文本。
@Toddleson，首先感谢您的回答。正如蒂莫西所说，我不能直接复制 ShapeRange 的项目，这就是我选择它的原因，但我想也许我可以设置另一个只包含 1 个 shaperange 项目的范围，然后复制这个范围。

标签： vba ms-word

【解决方案1】：

我不清楚为什么，但我意识到只有在显示形状所在的部分时才会复制形状。因此，在 for 循环中，在选择每个形状之前，我使用ActiveWindow.ScrollIntoView 来显示每个形状，然后我为 word 设置一秒的计时器来执行此任务，然后我选择并复制形状。

For i = 1 To MyRange.ShapeRange.Count 'search and copy/paste only images
        ActiveWindow.ScrollIntoView MyRange.ShapeRange.Item(MyRange.ShapeRange.Count + 1 -i), false
        StartTime = Timer
        Do While Timer < StartTime + 1
           DoEvents
        Loop
        MyRange.ShapeRange.Item(MyRange.ShapeRange.Count + 1 - i).Select
        Selection.Copy
        ThisDocument.Activate 'Activate document B
        Selection.GoTo What:=wdGoToBookmark, Name:="StateDiagram" 'go to bookmark where i want to paste images
        Selection.PasteSpecial Placement:=wdInLine 'paste on document B
        Documents(ADoc).Activate 'Activate A document
    Next i

【讨论】：