Microsoft Office Forums - View Single Post

gmaxey · 12-13-2012, 05:45 PM

Brent,

The following (very little error handling) should suffice for most simple mapping requirements. Just add titled CCs in your document and run the code. Copy and paste any titled CC to a new location and it is automatically mapped to the data node (and all other like titled CCs).

Code:

Sub MapAColectionOfCustomXMLParts()
Dim oCCs As New Collection
Dim oCXPart As CustomXMLPart
Dim oCC As ContentControl
Dim lngIndex As Long
Dim strTitle As String
  'Create a fresh CustomXMLPart for mapping.
  On Error Resume Next
  'Kill any existing CustomXMLPart used previously.
  Set oCXPart = ActiveDocument.CustomXMLParts.SelectByNamespace _
               ("http//mapCCcollection@namespace.com").Item(1)
  If Err.Number = 0 Then
    oCXPart.Delete
  End If
  On Error GoTo 0
  'Create the new CustomXMLPart.
  ActiveDocument.CustomXMLParts.Add _
                ("<CC_Collection xmlns='http//mapCCCollection@namespace.com'/>")
  Set oCXPart = ActiveDocument.CustomXMLParts.SelectByNamespace _
                ("http//mapCCCollection@namespace.com").Item(1)
 
  'Get unique titles.
  For Each oCC In ActiveDocument.ContentControls
    If oCC.Title <> "" Then
      On Error Resume Next
      oCCs.Add oCC, oCC.Title
    End If
  Next oCC
  On Error GoTo 0
 
  For lngIndex = 1 To oCCs.Count
    'Add a CustomXMLNode for eacj uniqued titled CC.
     Set oCC = oCCs(lngIndex)
     strTitle = Replace(oCC.Title, " ", "_")
     oCXPart.AddNode oCXPart.SelectSingleNode("ns0:CC_Collection"), _
                            strTitle, , , msoCustomXMLNodeElement
  Next lngIndex
  'Map titled CCs.
  For Each oCC In ActiveDocument.ContentControls
    If oCC.Title <> "" Then
      oCC.XMLMapping.SetMappingByNode oCXPart.SelectSingleNode("//" & Replace(oCC.Title, " ", "_") & "[1]")
    End If
  Next oCC
lbl_Exit:
  Exit Sub
End Sub