Shapes

[Kilroy]

I have this macro the searches a document and asks you if you want to delete it or not. Is there a way to just cut and paste all shapes to a new document that is saved in the same folder with the same name as the original but with an "_shapes" added to the file name? I have a macro that does this for tables but have been unable to adapt it for shapes/objects. Having them both in one macro would be ideal. Moving pictures as well would be super fantastic. Any help appreciated.

Sub DeleteShapes()

Dim oShape As Shape
Dim oStory As range
Dim lngIndex As Long
Dim lngView As Long
lngView = ActiveDocument.ActiveWindow.View
For Each oStory In ActiveDocument.StoryRanges
For lngIndex = oStory.ShapeRange.Count To 1 Step -1
Set oShape = oStory.ShapeRange.Item(lngIndex)
oShape.Anchor.Select
If MsgBox("Delete the selected shape?", vbYesNo) = vbYes Then
oShape.Delete
End If
Next lngIndex
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
For lngIndex = oStory.ShapeRange.Count To 1 Step -1
Set oShape = oStory.ShapeRange.Item(lngIndex)
oShape.Anchor.Select
If MsgBox("Delete the selected shape?", vbYesNo) = vbYes Then
oShape.Delete
End If
Next lngIndex
Wend
End If
Next oStory
lbl_Exit:
Set oShape = Nothing
Set oStory = Nothing
ActiveDocument.ActiveWindow.View = lngView
Exit Sub
End Sub

Sub CutAndPasteTables()
Dim oDoc As Document
Dim oSource As Document
Dim oTable As Table
Dim oRng As range
Dim strName As String 'sat the top with the other variables
Set oSource = ActiveDocument
If oSource.Tables.Count > 0 Then
Set oDoc = Documents.Add
Else
MsgBox "There are no tables in the current document"
GoTo lbl_Exit
End If
For Each oTable In oSource.Tables
oTable.range.Cut 'Copy?
Set oRng = oDoc.range
oRng.Collapse wdCollapseEnd
oRng.PasteAndFormat wdFormatOriginalFormatting
oDoc.range.InsertParagraphAfter
Next oTable
strName = oSource.FullName
strName = Left(strName, InStrRev(strName, Chr(46)) - 1) & " Tables.docx"
oDoc.SaveAs2 FileName:=strName  'Save the new document"
oDoc.Close
lbl_Exit:
Exit Sub
End Sub