Word Menu déroulant msgbox dans un word

Sub Liste()
Dim mem$, f$, x$, c As Range, message$
With [A1] 'à adapter
    On Error Resume Next
    If .Validation.Type <> 3 Then Exit Sub 'il faut une liste
    On Error GoTo 0
    mem = .Formula
    .Formula = .Validation.Formula1 'copie la formule de validation
    x = .Formula
    .Formula = mem
End With
If IsError(Evaluate(x)) Then
    MsgBox x
Else
    For Each c In Evaluate(x)
        message = message & vbLf & c
    Next
    MsgBox Mid(message, 2)
End If
End Sub

Sub Liste()
Dim c As ContentControl, n&, message$, i&
For Each c In ActiveDocument.ContentControls
    n = n + 1
    message = ""
    For i = 1 To c.DropdownListEntries.Count 'collection
        message = message & vbLf & c.DropdownListEntries(i)
    Next i
    If i > 1 Then MsgBox i - 1 & " éléments :" & vbLf & message, , "Contrôle " & n
Next c
End Sub

Option Explicit

Private Sub CommandButton1_Click()

Dim I As Integer

    For I = 1 To ContentControls.Count
        With ContentControls(I)
             If .Title = "Demandeur" Then MsgBox .Range
        End With
    Next I


End Sub

Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)

  MsgBox ContentControl.Range
  Cancel = False
 
End Sub