Option Explicit
Dim oCustPart As Office.CustomXMLPart
Sub AddContentControlAndMapToCustomXMLPart()
Dim oRng As Word.Range
Dim oCC As Word.ContentControl
Dim xPath As String
Dim pTitle As String
Dim pNodeBaseName As String
Set oRng = Selection.Range
On Error Goto Err_Handler
Set oCC = ActiveDocument.ContentControls.Add(wdContentControlText, oRng)
pTitle = InputBox("Type the title this ContentControl", "Create Title")
pNodeBaseName = Replace(pTitle, " ", "_") 'Node BaseNames can not contain spaces
CreateDataNode pNodeBaseName
xPath = "/Data/" & pNodeBaseName
With oCC
.Title = pTitle
.XMLMapping.SetMapping xPath
End With
Set oRng = Nothing
Set oCC = Nothing
Exit Sub
Err_Handler:
If Err.Number = 4605 Then
MsgBox "A content control already exists at the selected range. Please " _
& " select another location.", vbInformation + vbOKOnly, "Select Another Location"
End If
End Sub
Sub CreateCustomPart()
'Establish the base CustomXMLPart.
Set oCustPart = ActiveDocument.CustomXMLParts.Add _
("<?xml version='1.0' encoding='utf-8'?><Data></Data>")
ActiveDocument.Variables("custPartID").Value = oCustPart.ID
Set oCustPart = Nothing
End Sub
Sub CreateDataNode(ByRef pBaseName As String)
Dim oNode As CustomXMLNode
Set oCustPart = ActiveDocument.CustomXMLParts.SelectByID _
(ActiveDocument.Variables("custPartID").Value)
'Create a child node for the content control bound data.
If Not oCustPart Is Nothing Then
Set oNode = oCustPart.SelectSingleNode("/Data")
oCustPart.AddNode Parent:=oNode, Name:=pBaseName, NodeValue:=""
Set oCustPart = Nothing
Set oNode = Nothing
Else 'The base CustomXMLPart does not yet exist. Create it.
CreateCustomPart
CreateDataNode pBaseName
End If
End Sub
Sub CleanUp()
'Can be used to delete the CustomXMLPart used for mapping.
On Error Resume Next
Set oCustPart = ActiveDocument.CustomXMLParts.SelectByID _
(ActiveDocument.Variables("custPartID").Value)
oCustPart.Delete
On Error Goto 0
End Sub
|