Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, Rng As Range, StrType
With ActiveDocument
  For i = .Shapes.Count To 1 Step -1
    With .Shapes(i)
      If Not .TextFrame Is Nothing Then
        On Error GoTo SkipShp
        If Len(Trim(.TextFrame.TextRange.Text)) > 1 Then
          Select Case .Type
            Case msoAutoShape: StrType = "AutoShape"
            Case msoCallout: StrType = "Callout"
            Case msoCanvas: StrType = "Canvas"
            Case msoChart: StrType = "Chart"
            Case msoComment: StrType = "Comment"
            Case msoDiagram: StrType = "Diagram"
            Case msoEmbeddedOLEObject: StrType = "EmbeddedOLEObject"
            Case msoFormControl: StrType = "FormControl"
            Case msoFreeform: StrType = "Freeform"
            Case msoGroup: StrType = "Group"
            Case msoInk: StrType = "Ink"
            Case msoInkComment: StrType = "InkComment"
            Case msoLine: StrType = "Line"
            Case msoLinkedOLEObject: StrType = "LinkedOLEObject"
            Case msoLinkedPicture: StrType = "LinkedPicture"
            Case msoMedia: StrType = "Media"
            Case msoOLEControlObject: StrType = "OLEControlObject"
            Case msoPicture: StrType = "Picture"
            Case msoPlaceholder: StrType = "Placeholder"
            Case msoScriptAnchor: StrType = "ScriptAnchor"
            Case msoShapeTypeMixed: StrType = "ShapeTypeMixed"
            Case msoTable: StrType = "Table"
            Case msoTextBox: StrType = "TextBox"
            Case msoTextEffect: StrType = "TextEffect"
          End Select
          Set Rng = .Anchor
          With Rng
            .InsertBefore StrType & " start << "
            .Collapse wdCollapseEnd
            .InsertAfter " >> end " & StrType
            .Collapse wdCollapseStart
          End With
          Rng.FormattedText = .TextFrame.TextRange.FormattedText
          .Delete
        End If
SkipShp:
        On Error GoTo 0
      End If
    End With
  Next
  For i = .InlineShapes.Count To 1 Step -1
    With .InlineShapes(i)
      If Not .TextEffect Is Nothing Then
        On Error GoTo SkipiShp
        If Len(Trim(.TextEffect.Text)) > 1 Then
          Select Case .Type
            Case wdInlineShapeChart: StrType = "InlineChart"
            Case wdInlineShapeDiagram: StrType = "InlineDiagram"
            Case wdInlineShapeEmbeddedOLEObject: StrType = "InlineEmbeddedOLEObject"
            Case wdInlineShapeHorizontalLine: StrType = "InlineHorizontalLine"
            Case wdInlineShapeLinkedOLEObject: StrType = "InlineLinkedOLEObject"
            Case wdInlineShapeLinkedPicture: StrType = "InlineLinkedPicture"
            Case wdInlineShapeLinkedPictureHorizontalLine: StrType = "InlineShapeLinkedPictureHorizontalLine"
            Case wdInlineShapeLockedCanvas: StrType = "InlineLockedCanvas"
            Case wdInlineShapeOLEControlObject: StrType = "InlineOLEControlObject"
            Case wdInlineShapeOWSAnchor: StrType = "InlineOWSAnchor"
            Case wdInlineShapePicture: StrType = "InlinePicture"
            Case wdInlineShapePictureBullet: StrType = "InlinePictureBullet"
            Case wdInlineShapePictureHorizontalLine: StrType = "InlinePictureHorizontalLine"
            Case msoLinkedOLEObject: StrType = "LinkedOLEObject"
            Case wdInlineShapeScriptAnchor: StrType = "InlineScriptAnchor"
          End Select
          Set Rng = .Range
          With Rng
            .Collapse wdCollapseStart
            .InsertBefore StrType & " start << "
            .Collapse wdCollapseEnd
            .InsertAfter " >> end " & StrType
            .Collapse wdCollapseStart
          End With
          Rng.Text = .TextEffect.Text
          .Delete
        End If
SkipiShp:
        On Error GoTo 0
      End If
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub