在Word VBA宏中迭代并添加ContentControl

我有数百个word文档，它们有多个表。每个表行都有一个特定的自定义样式，用于标识单元格中的数据。需要遍历word文档，找到样式，并在该项上添加ContentControl。我遇到的问题是Selection.Find命令在文档开头重新启动，因此它最终嵌套ContentControls。我曾尝试添加一些计数机制，但尽管它解决了大多数问题，但它至少保留了一些ContentControls，并且确实有一些嵌套。我已尝试仅搜索特定表，但所选内容。查找将覆盖所选表。是否有一种方法可以从文档的开头到结尾进行迭代，以便动态添加内容控件？每个文档有2种不同类型的表。以下表格中只有一个：

此表中可以有1到100个：

contentControl应该将数据封装在文档级元数据列中。这是我到目前为止的代码

                Option Explicit

            Sub FindStyleReplaceWithCC()
            Dim CCtrl As ContentControl
            Do While ActiveDocument.ContentControls.Count > 0
                For Each CCtrl In ActiveDocument.ContentControls
                If CCtrl.LockContentControl = True Then CCtrl.LockContentControl = False
                CCtrl.Delete False
            Next
            Loop

            'For Each CCtrl In ActiveDocument.ContentControls
                'For Each CCtrl In ActiveDocument.ContentControls
                '    MsgBox (CCtrl.Range)
                'Next

            'Dim CCtrl As ContentControl
            Dim sty As Style
            Dim oTbl As Table
            ''''''''''''''''''''''''''''''''''''''''
            'Table 1
            Dim thearray(1 To 13, 1 To 2)
             Dim element As Variant
            Dim arrWsNames() As Variant
            Dim I As Integer
            arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
            "Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
            "Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs")

            For I = 1 To 13
            thearray(I, 1) = arrWsNames(I - 1)
            thearray(I, 2) = 0
            Next


            Dim howmany As Integer
            howmany = 0

            For Each element In arrWsNames

            Dim iterations As Integer
                        With Selection.Find
                            .ClearFormatting
                            .Style = ActiveDocument.Styles(element)
                            .Replacement.ClearFormatting
                            .Text = ""
                            .Replacement.Text = ""
                            .Forward = False
                            .Wrap = wdFindContinue
                        End With
                        Selection.Find.Execute
                        Selection.Range.ContentControls.Add (wdContentControlRichText)
                        Selection.ParentContentControl.Title = element
            Next
            '''''''''''''''''''''''''''''''''''''
            'Table 2

            Dim thearray2(1 To 8, 1 To 2)
            Dim arrWsNames2() As Variant
            arrWsNames2 = Array("Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
            "Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")

            For I = 1 To 8
            thearray2(I, 1) = arrWsNames2(I - 1)
            thearray2(I, 2) = 0
            Next

            howmany = 0

            For Each element In arrWsNames2
            iterations = 1

                For Each oTbl In ActiveDocument.Tables

                oTbl.Select

                        With Selection.Find
                            .ClearFormatting
                            .Style = ActiveDocument.Styles(element)
                            .Replacement.ClearFormatting
                            .Text = ""
                            .Replacement.Text = ""
                            .Forward = False
                            .Wrap = wdFindContinue
                        End With
                        Selection.Find.Execute
                        
                        If howmany + 1 = iterations Then
                            Selection.Range.ContentControls.Add (wdContentControlRichText)
                            Selection.ParentContentControl.Title = element
                            howmany = howmany + 1
                            iterations = iterations - 1
                        Else
                        iterations = iterations + 1
                        End If
                    
                Next
                
            Next

            MsgBox ("Done")

            End Sub

---

如果这不能在VBA中完成，可以在.net中完成吗？

这肯定可以在VBA中完成

您需要做的第一件事是停止使用

选择

对象。虽然有时必须使用

选择

，但大多数事情都可以通过使用

范围

来完成

我建议的下一件事是将代码分解为单独的例程，这些例程只执行解决方案的一个元素。这不仅使您能够简化代码，还将产生可重用的例程

我已按如下所示编辑了您的代码，并在O365中对带有子集或样式的文档进行了测试

Sub AddContentControlsForMetadata()
   RemoveContentControls ActiveDocument
   Dim element As Variant
   Dim arrWsNames() As Variant
   arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
      "Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
      "Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs", "Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
      "Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")
   For Each element In arrWsNames
      FindStyleReplaceWithCC ActiveDocument, CStr(element)
   Next element
     
End Sub

Sub RemoveContentControls(docTarget As Document)
  Dim ccIndex As Long
  For ccIndex = docTarget.ContentControls.Count To 1 Step -1
     With docTarget.ContentControls(ccIndex)
        If .LockContentControl = True Then .LockContentControl = False
        .Delete False
     End With
  Next ccIndex
End Sub


Sub FindStyleReplaceWithCC(searchDoc As Document, styleName As String)
   Dim findRange As Range
   Dim ccRange As Range
   
   Set findRange = searchDoc.Range
   
   With findRange.Find
      .ClearFormatting
      .Style = ActiveDocument.Styles(styleName)
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
   Do While .Execute = True
      If findRange.Information(wdWithInTable) Then
         findRange.Expand wdCell
      End If
      Set ccRange = findRange.Duplicate
      AddContentControlToRange ccRange, styleName
      'need to collapse the findRange so that Find can continue without finding the same location again
      findRange.Collapse wdCollapseEnd
   Loop
   End With
End Sub

Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String)
   ccLocation.ContentControls.Add(wdContentControlRichText).Title = ccTitle
End Sub

编辑： 要向内容控件添加标记和标题，请执行以下操作：

Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String, ByVal ccTag as String)
   With ccLocation.ContentControls.Add(wdContentControlRichText)
      .Title = ccTitle
      .Tag = ccTag
   End With
End Sub

---

这绝对可以在VBA中完成

您需要做的第一件事是停止使用

选择

对象。虽然有时必须使用

选择

，但大多数事情都可以通过使用

范围

来完成

我建议的下一件事是将代码分解为单独的例程，这些例程只执行解决方案的一个元素。这不仅使您能够简化代码，还将产生可重用的例程

我已按如下所示编辑了您的代码，并在O365中对带有子集或样式的文档进行了测试

Sub AddContentControlsForMetadata()
   RemoveContentControls ActiveDocument
   Dim element As Variant
   Dim arrWsNames() As Variant
   arrWsNames = Array("Sensitive Information Protection", "Applies To", "Functional Org", "Functional Process Owner", _
      "Topic Owner", "Subject Matter Experts", "Author", "Corporate Source ID", "Superior Source", "CIPS Legacy Document", _
      "Meta-Roles(DocLvl)", "SME Reviewer", "SourceDocs", "Meta-ReqType", "Meta-Roles", "Meta-Input", "Meta-Output", "Meta-Toolset", _
      "Meta-Sources", "Meta-Traced", "Meta-Objective_Evidence")
   For Each element In arrWsNames
      FindStyleReplaceWithCC ActiveDocument, CStr(element)
   Next element
     
End Sub

Sub RemoveContentControls(docTarget As Document)
  Dim ccIndex As Long
  For ccIndex = docTarget.ContentControls.Count To 1 Step -1
     With docTarget.ContentControls(ccIndex)
        If .LockContentControl = True Then .LockContentControl = False
        .Delete False
     End With
  Next ccIndex
End Sub


Sub FindStyleReplaceWithCC(searchDoc As Document, styleName As String)
   Dim findRange As Range
   Dim ccRange As Range
   
   Set findRange = searchDoc.Range
   
   With findRange.Find
      .ClearFormatting
      .Style = ActiveDocument.Styles(styleName)
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindStop
   Do While .Execute = True
      If findRange.Information(wdWithInTable) Then
         findRange.Expand wdCell
      End If
      Set ccRange = findRange.Duplicate
      AddContentControlToRange ccRange, styleName
      'need to collapse the findRange so that Find can continue without finding the same location again
      findRange.Collapse wdCollapseEnd
   Loop
   End With
End Sub

Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String)
   ccLocation.ContentControls.Add(wdContentControlRichText).Title = ccTitle
End Sub

编辑： 要向内容控件添加标记和标题，请执行以下操作：

Sub AddContentControlToRange(ByVal ccLocation As Range, ByVal ccTitle As String, ByVal ccTag as String)
   With ccLocation.ContentControls.Add(wdContentControlRichText)
      .Title = ccTitle
      .Tag = ccTag
   End With
End Sub

---

样式是应用于整行还是仅应用于第二列中的单元格？@timothyrylat-仅应用于第二列您应该能够使用表（i）.Range.Find来限制和循环表格。样式是否应用于整行，或者仅仅是第二列中的单元格？@timothyrylat-仅仅是第二列您应该能够使用表（i）.Range.Find来限制和循环表格。谢谢。这很有效，但我遇到过RemoveContentControls不执行CCTRL.Delete的情况，因此代码停留在Do…While中的infinate循环中。@FlyFish-抱歉，我承认我没有仔细查看您代码的这一部分。请参见上面编辑的答案。如果你仍然有问题，那么请给出它不起作用的情况的全部细节。谢谢你的帮助。必须添加一个结尾（我修改了上面的代码）。否则，这将非常有效。谢谢接受编辑，这将教会我不要在我的iPad上编辑代码！如何添加一个同时包含标题和标记的contentcontrol（或者，在添加带有上述标题的ContentControl后，您将如何将标记值添加到ContentControl？谢谢。这很有效，但我遇到了RemoveContentControls不执行CCTRL.Delete的情况，因此代码停留在Do…While中的infinate循环中。@FlyFish-抱歉，我不得不承认我没有仔细查看这部分代码。请参阅上面编辑的答案。如果您仍然有问题，请提供它不起作用的情况的完整详细信息。感谢您的帮助。必须添加一个结尾（我在上面修改了您的代码）。否则效果会很好。谢谢！！！接受编辑，这将教会我不要在我的iPad上编辑代码！您将如何添加一个同时包含标题和标记的contentcontrol（或者在使用上面的标题添加contentcontrol后，您将如何将标记值添加到contentcontrol？