Помогите пожалуйста, удаление рисунков

Sub ShapesTextOMFG()
Dim oShape As Shape
Dim oDoc As Document
Dim oStartPage As Range
Dim oEndPage As Range
    Set oDoc = ActiveDocument
    i = 0
For Each oShape In oDoc.Shapes
    'For i = 1 To oShape.GroupItems.Count
    '    Shapes = oShape.GroupItems(i).AlternativeText
    '    If Not Shapes = "" Then MsgBox Shapes
    'Next i
    sText = oShape.GroupItems(1).AlternativeText
    If Not sText = "" Then
        oShape.Delete
        i = i + 1
        Set oStartPage = ActiveDocument.Range.GoTo(wdGoToPage, wdGoToAbsolute, i)
        Set oEndPage = ActiveDocument.Range.GoTo(wdGoToPage, wdGoToAbsolute, i)
        oDoc.Range(oStartPage.Start, oEndPage.End).Select
        Selection.Range = sText
    End If
    If sText = "" Then oShape.Delete
Next oShape
If oDoc.Shapes.Count > 0 Then Call CheckoDoc
Call ClearMe("^0013")
Call ClearMe("^0032")
End Sub
Private Sub CheckoDoc()
Dim oDoc As Document
Dim oShape As Shape
Set oDoc = ActiveDocument
iCount = oDoc.Shapes.Count
Do While iCount > 0
For Each oShape In oDoc.Shapes
    oShape.Select
    oShape.LockAspectRatio = msoFalse
    oShape.Delete
Next oShape
iCount = oDoc.Shapes.Count
Loop
End Sub
Private Sub ClearMe(ByVal sText As String)
Select Case sText
Case "^0013": sRepl = Chr(13)
Case "^0032": sRepl = Chr(32)
End Select
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Execute FindText:="[" & sText & "]{2;}", MatchWildcards:=True, Forward:=True, Wrap:=wdFindContinue, ReplaceWith:=sRepl, Replace:=wdReplaceAll
End With
End Sub