How to update multiple Word Content Controls through VBS at once? - vba

Question

I am trying to feed data from an Excel sheet array (Udaje) to populate a several word documents from a template (hence the For in the example). I would like to insert some of the data to several Content Controls (text) at the same time. I am calling them by Tags and I know that I have to specify by adding .Item() - but then I only update one of the Content Controls.
Is there any way to overcome this restriction? I was thinking about cycling the tags with for but it seems to be a bit clumsy as I do not know how many tags I have to go through. I am a beginner at the VBA.
Or should I be using bookmarks instead?
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
Edit: the solution I chose in the end was to go through CCs in the document according to their Index number and set the value of each CC according to its tag:
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
Edit: loop code
...
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
The Suprocedure declaration line is where the error ocurres.

Answer 1

Even though you've already found an approach that works for you, here's a tip that bases on the starting point you provide in your Question. You're using SelectContentControlsByTag, then only addressing the first of the controls found, using .Item(1).
This method returns an array of content controls and you don't have to know, going in, how many: you can use a For Each loop to cycle through as many as there are in the array. And so that you don't need to repeat the code of the loop for each tag, put that in a separate procedure, passing the array plus the value to be assigned to content controls with the same tag to it.
So something like this:
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

To do it using the Custom XML Part way, you could use the following code. As it stands, it needs to be in a single module.
You would use replaceAndLinkCxp to create/recreate the necessary Custom XML Part (i.e. it's a one off).
You would use linkedTaggedCcsToCxps to link/relink your Tagged content controls to the correct Cxp/Element (also a one-off). To work with the document, it would probably be simpler to create a Content Control for each tag, connect them using this routine, then create an autotext for the control.
You would use something based on populateCxpData to put the data in your Cxp.
There are quite a few assumptions (e.g. all the content controls are plain text, Element names are the same as tag names) and plenty of scope for improvement.
' 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