Private Sub Document_ContentControlOnExit(ByVal CCtrl As ContentControl, Cancel As Boolean)
Application.ScreenUpdating = False
Dim strTxt As String, Rng As Range
With CCtrl
  If .Tag <> "Dropdown" Then Exit Sub
  If .ShowingPlaceholderText = True Then
    .Range.Font.StrikeThrough = False
    .Range.Font.Bold = False
    Exit Sub
  End If
  strTxt = .Range.Text
  If InStr(strTxt, "\") > 0 Then Exit Sub
  .Type = wdContentControlRichText
  .Range.Font.StrikeThrough = False
  .Range.Font.Bold = False
  With .Range
    .Text = "High\Significant\Low"
    .Font.StrikeThrough = True
    Set Rng = .Duplicate
    With Rng
      .End = .Start + InStr(.Text, "\")
      .Start = .End - 1
      .Font.StrikeThrough = False
    End With
    Set Rng = .Duplicate
    With Rng
      .End = .Start + InStrRev(.Text, "\")
      .Start = .End - 1
      .Font.StrikeThrough = False
    End With
    Set Rng = .Duplicate
    With Rng
      .Start = .Start + InStr(.Text, strTxt) - 1
      If InStr(.Text, "\") > 1 Then .End = .Start + InStr(.Text, "\") - 1
      .Font.StrikeThrough = False
      .Font.Bold = True
    End With
  End With
  .Type = wdContentControlDropdownList
End With
End Sub