如何通过VBS一次更新多个单词内容控件？

Question

我试图从Excel工作表数组(Udaje)中输入数据，以从模板中填充几个word文档(因此在本例中为For )。我想同时将一些数据插入到几个内容控件(文本)中。我是通过标记来调用它们的，我知道我必须通过添加.Item()来指定它们--但是之后我只更新了其中一个内容控件。

有没有办法克服这个限制？我想骑自行车的标签，但这似乎有点笨拙，因为我不知道我要经过多少标签。我是VBA的初学者。

还是我应该用书签代替？

For i = 1 To LastRow
       '.SelectContentControlsByTag("NapRozhodnuti").Item(1).Range.Text =  Udaje(i, 4)
       .SelectContentControlsByTag("ZeDne").Item(1).Range.Text = Udaje(i, 5)
       .SelectContentControlsByTag("NapadRozkladu").Item(1).Range.Text = Udaje(i, 6)
       .SelectContentControlsByTag("Ucastnik").Item(1).Range.Text = Udaje(i, 2)
       .SelectContentControlsByTag("DatumRK").Item(1).Range.Text = DatumRK
       .SelectContentControlsByTag("NavrhRK").Item(1).Range.Text = NavrhRK
       .SelectContentControlsByTag("OblastRK").Item(1).Range.Text = OblastRK
       .SelectContentControlsByTag("Tajemnik").Item(1).Range.Text = Tajemnik
       .SelectContentControlsByTag("Gender").Item(1).Range.Text = Gender
       .SaveAs2 Filename:= i & " - dokumenty_k_RK.docx", _
            FileFormat:=wdFormatDocument     
Next i

编辑:我最后选择的解决方案是根据文档中的索引号遍历CCs，并根据其标记设置每个CC的值：

For i = 1 To LastRow
   For y = 1 To CCNumber
    Select Case .ContentControls(y).Tag
        Case "NapRozhodnuti"
             .ContentControls(y).Range.Text = Udaje(i, 4)
        Case "ZeDne"
             .ContentControls(y).Range.Text = Udaje(i, 5)
        Case "NapadRozkladu"
             .ContentControls(y).Range.Text = Udaje(i, 6)
        Case "Ucastnik"
             .ContentControls(y).Range.Text = Udaje(i, 2)
        Case "DatumRK"
             .ContentControls(y).Range.Text = DatumRK
        Case "NavrhRK"
             .ContentControls(y).Range.Text = NavrhRK
        Case "OblastRK"
             .ContentControls(y).Range.Text = OblastRK
        Case "Tajemnik"
             .ContentControls(y).Range.Text = Tajemnik
        Case "Gender"
             .ContentControls(y).Range.Text = Gender
    End Select
    Next y
    .SaveAs2 Filename:="..." & i & " - dokumenty_k_RK.docx", _
        FileFormat:=wdFormatDocument
  Next i 

编辑:循环代码

...
Set objWord = CreateObject("Word.Application")
 objWord.Visible = True
 objWord.Documents.Open "\\fs1\homes\rostislav.janda\Documents\320\pozvanka_prazdna.docx" 

 With objWord.ActiveDocument 
   Set ccs = .SelectContentControlsByTag("Spznrozkladu")
    LoopCCs ccs, Udaje(i, 1)
   .SaveAs2 Filename:="\\fs1\homes\rostislav.janda\Documents\320\výstup\pozvanka.docx", _
        FileFormat:=wdFormatDocument 'uloží s formátem .docx
   .Saved = True 
 End With
 objWord.Quit 
 Set objWord = Nothing
End Sub


*Sub LoopCCs(ccs As Word.ContentControls, val As String)*
    Dim cc As Word.ContentControl
    For Each cc In ccs
       cc.Range.Text = val
    Next cc
    End Sub

超程序声明行是错误锁定的位置。

Answer 1

尽管您已经找到了一种适合您的方法，但这里有一个基于您在问题中提供的起点的提示。您使用的是SelectContentControlsByTag，然后只寻址找到的第一个控件，使用.Item(1)。

这个方法返回一个内容控件数组，您不需要知道其中有多少:您可以使用For Each循环循环遍历数组中的多少。这样您就不需要对每个标记重复循环的代码，将其放在一个单独的过程中，将数组加上要分配给具有相同标记的内容控件的值传递给它。

所以就像这样：

With doc
    'Like this
    Set ccs = .SelectContentControlsByTag("test")
    LoopCCs ccs, Udaje(i, 4)
    'Or like this
    LoopCCs  .SelectContentControlsByTag("ZeDne"), Udaje(i, 5)
End With

'Code is VBA and demonstrates the Word object model data types
'For VBS don't declare as types or type as Object
Sub LoopCCs(ccs as Word.ContentControls, val as String)
    Dim cc as Word.ContentControl

    For Each cc In ccs
       cc.Range.Text = val
    Next cc
End Sub

Answer 2

若要使用自定义XML部分方式执行此操作，可以使用以下代码。就目前情况而言，它需要在一个模块中。

您可以使用replaceAndLinkCxp创建/重新创建所需的自定义XML部件(也就是说，它是一次性的)。

您可以使用linkedTaggedCcsToCxps将标记的内容控件链接/重新链接到正确的Cxp/元素(也是一次性的)。要处理文档，可能更简单的方法是为每个标记创建一个control，使用这个例程连接它们，然后为控件创建一个自动文本。

您可以使用基于populateCxpData的东西将数据放入Cxp中。

有相当多的假设(例如，所有的内容控件都是纯文本，元素名称与标记名称相同)，还有很多需要改进的地方。

' This should be a name that belongs to you/your organisation
' It should also be unique for each different XML part structure
' you create. i.e. if you have one XML part with elements a,b,c
' and another with elements a,b,d, give them different namespace
' names.
Const sNameSpace = "hirulau"

' Specify the root element name for the part
Const sRootElementName = "ccdata"


Sub replaceAndLinkCxp()
' This deletes any existing CXP with the namespace specified
' in sOldNamespace, and creates a new CXP with the namespace
' in sNamespace. Any data in the CXP is lost.

' Then it links each Content Control with a tag name
' the same as an Element name in the part

' The old namespace (can be the same as the new one)
Const sOldNamespace = "hirulau"

Dim cc As Word.ContentControl
Dim ccs As Word.ContentControls
Dim cxp As Office.CustomXMLPart
Dim cxps As Office.CustomXMLParts
Dim i As Long
Dim s As String

' Specify the number and names of the elements and tags
' Each Element name should be unique, and a valid XML Element name
' and valid Content Control Tag Name
' (No nice way to do this in VBA - could just have a string and split it)

' NB, your CC tag names do not *have* to be the same as the XML Element
' names, but in this example we are making them that way
Dim sElementName(8) As String
sElementName(0) = "NapRozhodnuti"
sElementName(1) = "ZeDne"
sElementName(2) = "NapadRozkladu"
sElementName(3) = "Ucastnik"
sElementName(4) = "DatumRK"
sElementName(5) = "NavrhRK"
sElementName(6) = "OblastRK"
sElementName(7) = "Tajemnik"
sElementName(8) = "Gender"

' remove any existing CXPs with Namespace sOldNamespace

Set cxps = ActiveDocument.CustomXMLParts.SelectByNamespace(sOldNamespace)
For Each cxp In cxps
  cxp.Delete
Next
Set cxps = Nothing
'Debug.Print ActiveDocument.CustomXMLParts.Count

' Build the XML for the part
s = "<" & sRootElementName & " xmlns=""" & sNameSpace & """>" & vbCrLf
For i = LBound(sElementName) To UBound(sElementName)
  s = s & "  <" & sElementName(i) & " />" & vbCrLf
Next
s = s & "</" & sRootElementName & ">"
'Debug.Print s

' Create the Part
Set cxp = ActiveDocument.CustomXMLParts.Add(s)

' For each element/tag name, find the ccs with the tag
' and connect them to the relevant element in the part

For i = LBound(sElementName) To UBound(sElementName)
  For Each cc In ActiveDocument.SelectContentControlsByTag(sElementName(i))
    ' the "map:" is just a local mapping to the correct namespace.
    ' It doesn't have any meaning outside this method call.
    cc.XMLMapping.SetMapping "/map:" & sRootElementName & "/map:" & sElementName(i) & "[1]", "xmlns:map=""" & sNameSpace & """", cxp
  Next
Next

Set cxp = Nothing

End Sub

Sub linkTaggedCcsToCxps()
' Finds our Custom part, then relinks all controls with
' tag names that correspond to its *top level element names*
' So as long as you tag a suitable content control correctly,
' you can use this routine to make it point at the correct Cxp Element
Dim cc As Word.ContentControl
Dim cxn As Office.CustomXMLNode
Dim cxps As Office.CustomXMLParts

' Notice that we need the correct namespace name to do this
Set cxps = ActiveDocument.CustomXMLParts.SelectByNamespace(sNameSpace)
If cxps.Count = 0 Then
  MsgBox "Could not find the expected Custom XML Part."
Else
  ' Iterate through all the *top-level* child Element nodes
  For Each cxn In cxps(1).SelectNodes("/*/*")
    For Each cc In ActiveDocument.SelectContentControlsByTag(cxn.BaseName)
      ' the "map:" is just a local mapping to the correct namespace.
      ' It doesn't have any meaning outside this method call.
      cc.XMLMapping.SetMapping "/map:" & sRootElementName & "/map:" & cxn.BaseName & "[1]", "xmlns:map=""" & sNameSpace & """", cxps(1)
    Next
  Next
End If
Set cxps = Nothing
End Sub

Sub populateCxpData()

Dim sXpPrefix As String

' You would need to populate the following things
Dim i As Integer
Dim Udaje(1, 6) As String
Dim DatumRK As String
Dim NavrhRK As String
Dim OblastRK As String
Dim Tajemnik As String
Dim Gender As String
i = 1
' we need the namespace, but this time assume that we can use
' the first part with that namespace (and that it exists)
With ActiveDocument.CustomXMLParts.SelectByNamespace(sNameSpace)(1)
  sXpPrefix = "/*/" & .NamespaceManager.LookupPrefix(sNameSpace) & ":"
  .SelectSingleNode(sXpPrefix & "NapRozhodnuti[1]").Text = Udaje(i, 4)
  .SelectSingleNode(sXpPrefix & "ZeDne[1]").Text = Udaje(i, 5)
  .SelectSingleNode(sXpPrefix & "NapadRozkladu[1]").Text = Udaje(i, 6)
  .SelectSingleNode(sXpPrefix & "Ucastnik[1]").Text = Udaje(i, 2)
  .SelectSingleNode(sXpPrefix & "DatumRK[1]").Text = DatumRK
  .SelectSingleNode(sXpPrefix & "NavrhRK[1]").Text = NavrhRK
  .SelectSingleNode(sXpPrefix & "OblastRK[1]").Text = OblastRK
  .SelectSingleNode(sXpPrefix & "Tajemnik[1]").Text = Tajemnik
  .SelectSingleNode(sXpPrefix & "Gender[1]").Text = Gender
End With

End Sub