Hi Paul,
Thanks for you interest in this process. It seems this is like chasing a greased pig and has become quite the hairball. First just ActiveDocument.ContentControls will skip all the other storyranges and then there is the richtext CCs that may have nested CCs and the goal may only be to clear them. Here is another stab that I think is getting closer to the polished cannonball:
Option Explicit
Sub Demo()
Dim colCCs As New Collection
Dim lngCC As Long
Dim oCC As ContentControl
Dim lngIndex As Long
Dim bUnlock As Boolean, bUARSections As Boolean
Set colCCs = fcnGetDocCCCollection(ActiveDocument)
Application.ScreenUpdating = False
On Error GoTo Err_Locked
For lngCC = colCCs.Count To 1 Step -1
Set oCC = ActiveDocument.ContentControls(colCCs.Item(lngCC))
bUnlock = False
With oCC
Select Case .Type
Case 0
If oCC.Range.ContentControls.Count = 0 Then
If bUnlock Then .LockContents = False
ResetRTCCRange oCC
If bUnlock Then .LockContents = True
Else
If .LockContents Then
If MsgBox("Processing encountered a content control locked for editing. Do you want " _
& "to reset the locked content control?", vbQuestion + vbYesNo, "LOCKED CONTENT") = vbYes Then
.LockContents = False
bUnlock = True
End If
End If
If Not .LockContents Then
If MsgBox("Processing encountered a rich text content control contain one or more nested content controls." & vbCr + vbCr _
& "With this condition the content control may contain content you wish to keep." & vbCr + vbCr _
& "Click ""Yes"" to reset only content nested in other controls." & vbCr + vbCr _
& "Click ""No"" to clear and reset all content?", vbQuestion + vbYesNo, "KEEP COTNENT") = vbYes Then
ResetRTCCRange oCC
Else
ResetRTCCRange oCC, True
End If
End If
If bUnlock Then .LockContents = True
End If
Case 1, 3, 5, 6
If bUnlock Then .LockContents = False
.Range.Text = vbNullString
If bUnlock Then .LockContents = True
Case 2
If bUnlock Then .LockContents = False
.Range.InlineShapes(1).Delete
If bUnlock Then .LockContents = True
Case 4
.Type = wdContentControlText
If bUnlock Then .LockContents = False
.Range.Text = vbNullString
If bUnlock Then .LockContents = True
.Type = wdContentControlDropdownList
Case 8
If bUnlock Then .LockContents = False
.Checked = False
If bUnlock Then .LockContents = True
Case 9
bUARSections = True
If Not .AllowInsertDeleteSection Then
If MsgBox("Processing encountered a repeating section content control locked from removing repeating sections. Do you want " _
& "to remove the repeating sections?", vbQuestion + vbYesNo, "LOCKED CONTENT") = vbYes Then
.AllowInsertDeleteSection = True
Else
bUARSections = False
End If
End If
If .LockContents Then
If MsgBox("Processing encountered a repeating section content control locked for editing. Do you want " _
& "to reset the locked content control?", vbQuestion + vbYesNo, "LOCKED CONTENT") = vbYes Then
.LockContents = False
With .RepeatingSectionItems
Do While .Count > 1
For lngIndex = .Item(.Count).Range.ContentControls.Count To 1 Step -1
.Item(.Count).Range.ContentControls(lngIndex).LockContentControl = False
Next lngIndex
If bUARSections Then .Item(.Count).Delete
Loop
End With
.LockContents = True
End If
Else
With .RepeatingSectionItems
Do While .Count > 1
For lngIndex = .Item(.Count).Range.ContentControls.Count To 1 Step -1
.Item(.Count).Range.ContentControls(lngIndex).LockContentControl = False
Next lngIndex
If bUARSections Then .Item(.Count).Delete
Loop
End With
End If
.AllowInsertDeleteSection = bUARSections
End Select
End With
Next
lbl_Exit:
Application.ScreenUpdating = True
Exit Sub
Err_Locked:
Select Case Err.Number
Case 6124
If MsgBox("Processing encountered a content control locked for editing. Do you want " _
& "to reset the locked content control?", vbQuestion + vbYesNo, "LOCKED CONTENT") = vbYes Then
bUnlock = True
oCC.LockContents = False
Resume
Else
Resume Next
End If
Case Else
MsgBox Err.Number & " " & Err.Description
Resume lbl_Exit
End Select
End Sub
Sub ResetRTCCRange(oCC As ContentControl, Optional bResetRTCC As Boolean = False)
Dim lngIndex As Long
On Error Resume Next
For lngIndex = oCC.Range.Tables.Count To 1 Step -1
oCC.Range.Tables(lngIndex).Delete
Next
If oCC.Range.ContentControls.Count = 0 Then oCC.Range.Text = vbNullString
For lngIndex = oCC.Range.ContentControls.Count To 1 Step -1
With oCC.Range.ContentControls(lngIndex)
.LockContentControl = False
.LockContents = False
.Range.Text = vbNullString
End With
Next lngIndex
On Error GoTo 0
If bResetRTCC Then oCC.Range.Text = vbNullString
lbl_Exit:
Exit Sub
End Sub
'***************************************For Working With Content Controls******************************************
Public Function fcnGetDocCCCollection(oDoc As Document) As Collection
Dim lngValidator As Long
Dim oStoryRng As Word.Range
Dim oCC As ContentControl
Dim oShp As Shape, oCanShp As Shape
Dim strSelectedID As String
Dim lngItems As Long
Dim oColCCs As Collection
Set oColCCs = New Collection
lngValidator = oDoc.Sections(1).Headers(1).Range.StoryType
For Each oStoryRng In oDoc.StoryRanges
'Iterate through all linked stories
Select Case oStoryRng.StoryType
Case 1 To 11
Do
On Error Resume Next
For Each oCC In oStoryRng.ContentControls
oColCCs.Add oCC.ID, oCC.ID
Next oCC
Select Case oStoryRng.StoryType
Case 6, 7, 8, 9, 10, 11
If oStoryRng.ShapeRange.Count > 0 Then
For Each oShp In oStoryRng.ShapeRange
On Error GoTo Err_HasText
If oShp.TextFrame.HasText Then
For Each oCC In oShp.TextFrame.TextRange.ContentControls
oColCCs.Add oCC.ID, oCC.ID
Next oCC
End If
If oShp.Type = msoCanvas Then
For Each oCanShp In oShp.CanvasItems
If oCanShp.TextFrame.HasText Then
For Each oCC In oCanShp.TextFrame.TextRange.ContentControls
oColCCs.Add oCC.ID, oCC.ID
Next oCC
End If
Next oCanShp
End If
Err_HasText_ReEntry:
Next oShp
End If
Case Else
'Do Nothing
End Select
'Get next linked story (if any)
Set oStoryRng = oStoryRng.NextStoryRange
Loop Until oStoryRng Is Nothing
Case Else
End Select
Next oStoryRng
Set fcnGetDocCCCollection = oColCCs
Set oColCCs = Nothing
lbl_Exit:
Exit Function
Err_HasText:
Resume Err_HasText_ReEntry
End Function