Sub AddContentControlAndMapToLocalXML()
Dim oCC As Word.ContentControl
Dim oCustomPart As Office.CustomXMLPart
Dim xmlPart As String
Dim oDoc As Word.Document
Dim oRng As Word.Range
Dim strQuery As String
Dim lngIndex As Long
Dim strCC_Title As String
Dim bTitled As Boolean
  Set oDoc = ActiveDocument
  bTitled = False
  ClearXMLParts
  xmlPart = "<?xml version='1.0' encoding='utf-8'?><Root><Item></Item></Root>"
  Set oCustomPart = oDoc.CustomXMLParts.Add(xmlPart)
  strQuery = InputBox("Enter text to bind to Content Controls", "Find and Bind")
  'Deal with existing CCs
  'Find the title for any existing CC who's contents match the querry.
  For lngIndex = 1 To oDoc.ContentControls.Count
    Set oCC = oDoc.ContentControls(lngIndex)
    If oCC.Range.Text = strQuery Then
      'Define title.
      If Not bTitled Then
        'Is CC titled?
        strCC_Title = ActiveDocument.ContentControls(lngIndex).Title
        If Len(strCC_Title) > 0 Then
          bTitled = True
        Else
          Do
            strCC_Title = InputBox("Enter a CC title")
            If StrPtr(strCC_Title) = 0 Then GoTo lbl_Exit 'User canceled
          Loop Until strCC_Title <> ""
          oCC.Title = strCC_Title
        End If
      End If
      'Is the CC mapped?
      If Not oCC.XMLMapping.IsMapped Then
        'Map it.
        oCC.XMLMapping.SetMapping "/Root/Item[1]", , oCustomPart
      End If
    End If
  Next lngIndex
  'Find text, add and map CCs.
  Set oRng = ActiveDocument.Range
  If Len(strCC_Title) = 0 Then
    Do
      strCC_Title = InputBox("Enter a CC title")
      If StrPtr(strCC_Title) = 0 Then GoTo lbl_Exit 'User canceled
    Loop Until strCC_Title <> ""
  End If
  With oRng.Find
    .Text = strQuery
    .Wrap = wdFindStop
    While .Execute
      Set oCC = oDoc.ContentControls.Add(wdContentControlText, oRng)
      oCC.XMLMapping.SetMapping "/Root/Item[1]", , oCustomPart
      oCC.Range.Text = strQuery
      oCC.Title = strCC_Title
      oRng.Collapse wdCollapseEnd
      Do While oRng.InRange(oCC.Range)
        oRng.Move wdCharacter, 1
      Loop
    Wend
  End With
lbl_Exit:
  Exit Sub
End Sub
'Run ClearXMLParts prior to testing these examples.
Sub ClearXMLParts()
Dim lngIndex As Long
'MsgBox ActiveDocument.CustomXMLParts.Count
For lngIndex = ActiveDocument.CustomXMLParts.Count To 4 Step -1
  ActiveDocument.CustomXMLParts(lngIndex).Delete
Next lngIndex
End Sub