在Word VBA宏中迭代并添加ContentControls

如何解决在Word VBA宏中迭代并添加ContentControls

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

此表可以有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中完成。

您需要做的第一件事就是停止使用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