在 Word VBA 宏中迭代并添加 ContentControls

Question

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

这个表可以有 1 到 100 个：

contentControl 应该将数据封装在 Document Level Metadata 列中。这是我到目前为止的代码

                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 中完成？

Answer 1

这绝对可以在 VBA 中完成。

您需要做的第一件事是停止使用Selection 对象。虽然在某些情况下必须使用Selection，但大多数事情都可以通过使用Range 来完成。

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

我已按如下方式编辑了您的代码，并在 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