Vba 用于重置word文档中插入的文本框计数器的代码

我有一个代码将粗体文本从textbox复制到所选表的第2列。然而 此代码不是按顺序标识文本框，而是从文档中首先插入的文本框复制文本，依此类推。如果文本框未按顺序插入，则会产生问题。例如，如果文本框2插入文档中文本框1的上方，则文本框2中的文本将首先复制到表中

如何重置所有文本框的顺序，使文本始终从第一个文本框复制到最后一个文本框

'This code copies bold text from the textboxes and insert into the column 2 of the selected table
Sub Copy_text_from_textbox_into_table()
Dim nNumber As Integer
Dim strText As String
Dim i As Long
Dim doc As Document
Dim tbl As Table
Dim rng As Range
Dim shp As Shape

Set doc = ActiveDocument
Selection.Collapse Direction:=wdCollapseStart
Set tbl = Selection.Tables(1)

      i = 0

With doc
    For Each shp In .Shapes

        If shp.Type = msoTextBox Then


        Set rng = shp.TextFrame.TextRange
            With rng.Find
                .Font.Bold = True
                .Wrap = wdFindStop
                .Execute
                strText = rng.Text
            End With
            i = i + 1
            With tbl.Cell(Row:=i + 1, Column:=2).Range
                .Delete
                .InsertAfter Text:=strText
            End With

        Else
            MsgBox ("There is no textbox.")
                     End If
  Next
End With
End Sub

---

您要处理的问题是文本框的定位位置。这是文档文本流中管理形状的位置。如果您查看底层XML，您可以看到它是如何工作的，但这对于理解发生了什么并不是必需的。要查看这些定位，请转到“始终在屏幕上显示这些格式标记”部分中的“文件/选项/显示”并激活对象定位。注意：这些不打印出来；另一个术语是非打印字符

通常，当用户插入文本框时，它将定位到所选内容所在的段落。如果随后拖动文本框，则锚定将移动，除非它已明确锁定到位。当代码插入文本框时，它将锚定到锚定参数指定的范围；如果这还没有定下来，那就有点像彩票

当Word在Shapes集合中运行时，它跟随文档中的连续文本，按照锚定的顺序拾取形状，而不管对象可能出现在页面上的什么位置

这个非常复杂的需求的完整解决方案超出了堆栈溢出的范围。下面说明了有关所涉及的内容以及如何处理这些内容的基本知识

简单的方法

解决这个问题的一种方法是循环形状，将每个对象添加到数组或集合中。检查数组或集合中每个对象相对于页边距的垂直/水平位置。然后根据此信息对数组/集合进行排序。最后，遍历已排序的数组/集合，并将内容分配给表

由于形状位置可以是相对于定位点、边距或页面的，这样做会更加复杂

下面的代码显示了一种可能的方法，可以按照文本框在页面上显示时从上到下的正确顺序获取文本框

为清楚起见，将内容写入表的步骤已被省略，但会在发生此操作时插入注释

代码

代码执行三个forloop。第一个循环循环文档中的所有形状，并测试每个形状是否为文本框。如果是，则将所需的属性写入用户定义的类型，然后将该类型分配给数组。这样做是为了提高效率：循环一个类型的数组比在以后的循环中再次寻址每个形状对象要快

还要注意的是，在每次迭代之前，形状被显式设置为相对于页面定位，而不是其他任何位置。这意味着文本框不会随文本在页面上移动。如果需要，则需要添加另一个复杂级别，以确定每个文本框的相对位置，并基于此计算相对于页面的位置。或者，可以更改设置，但需要进行测试以确保文本框不会移动。无论如何，这种复杂程度超出了这个问题的范围

由于我们需要形状对象或识别该对象及其位置信息的方法，因此需要多维数组。代码启动时，元素文本框的数量未知，因此需要在运行时对数组进行尺寸标注。但是Redim Preserve只能更改最后一个维度，因此不适合此目的。因此，信息不能直接分配给多维数组，这就是为什么它首先分配给用户定义类型的数组，该数组携带所有信息

对数组进行尺寸标注后，将从类型的数组中为其指定位置信息以及索引值。同时，将填充第三个数组，其中包含索引值和形状名称

第三个数组的原因是WordBasic.SortArray用于按页面上形状的顶部位置对数组进行排序。这会将所有元素强制为相同的数据类型，这意味着不会保留Shape.Name的字符串值

最后，代码循环排序后的数组，该数组现在按页面上每个文本框的升序排列。§

Public Type DocShapes
    shpName As String
    top As Double
    left As Double
End Type

Sub GetTextBoxPositionalOrder()
    Dim doc As Word.Document
    Dim shp As Word.Shape
    Dim aShapes() As Variant
    Dim counter As Long, i As Long
    Dim shpType As DocShapes
    Dim shpTypes() As DocShapes
    Dim shpIndex() As Variant

    counter = 0
    Set doc = ActiveDocument
    For Each shp In doc.Shapes
        'Count the shapes to dimension the array and
        'assign to user-defined Type
        If shp.Type = msoTextBox Then
            shp.RelativeVerticalPosition = wdRelativeVerticalPositionPage
            shp.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
            shpType.shpName = shp.Name
            shpType.left = shp.left
            shpType.top = shp.top
            ReDim Preserve shpTypes(counter)
            shpTypes(counter) = shpType
            counter = counter + 1
         End If
    Next

    ReDim Preserve aShapes(counter - 1, 2)
    ReDim Preserve shpIndex(counter - 1, 1)

    For i = LBound(shpTypes) To UBound(shpTypes)
        shpIndex(i, 0) = i + 1
        shpIndex(i, 1) = shpTypes(i).shpName
        aShapes(i, 2) = i 'corresponds to the index
        aShapes(i, 0) = shpTypes(i).top
        aShapes(i, 1) = shpTypes(i).left
    Next
    WordBasic.SortArray aShapes, 0, 0, UBound(aShapes), 0, 0
    For i = LBound(aShapes) To UBound(aShapes)
'''Write the text box content to the table at this point
        Debug.Print shpIndex(aShapes(i, 2), 1), aShapes(i, 0), aShapes(i, 1)
    Next
End Sub

§请注意，此代码适用于单页文档。如果您需要在上处理文本框 多页，则需要添加一个维度：每个形状位于哪个页面上。然后，文本框信息首先需要按页面排序，然后按每页上的位置排序。或者将其设置为一次处理一个页面的形状

---

也可以使用不同的排序算法——有很多。我使用WordBasic.Sortaray是因为1它是内置的，2我无法花时间研究各种排序算法。

谢谢。我在一个单页文档上尝试了多次，但是文本框没有得到排序。完整代码见附件。不知道我做错了什么。我使用的代码与建议的代码相同，并插入了用于在指定点复制文本的代码。@Quantmodels无法将代码附加到SO注释或任何其他内容。请注意，您从未提供过一个示例，以便其他人只能猜测您正在使用的内容。我在发帖前做了多次测试。如果你没有更详细的信息来重现这个问题，任何人都无能为力。。。但是您应该在不复制代码的情况下进行测试，首先，要确保基础工作正常……您还应该研究排序算法。我的答案不是复制并在代码中使用，而是解决方案——考虑到主题的复杂性，这根本不可能。我只描述了所涉及的内容以及如何着手创建一个针对特定需求定制的解决方案，@Quantmodels。当然，谢谢，我会尝试的