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

[macropod]

Why not simply copy the entire document, then delete all the text? You could do the latter with a simple Find/Replace:
Find = ^?
Replace = nothing
Inline and floating shapes will be preserved (so, too, will be emptied tables).

[Kilroy]

Paul thanks for the reply. It's actually the text that I need to keep for further processing. I have a series of other macros that I run. I need everything that is not text removed to another document for review so I can more easily figure what I need and what I don't. The documents I work with are very long. The macro you supplied is still very useful to me in other situations so thanks for that.

[macropod]

In your first post, you said:

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? ... Moving pictures as well would be super fantastic.
That's what the process I suggested achieves.


Conversely, to delete inlineshapes, you might use:
Find = ^g
Replace = nothing
If you have floating shapes, a macro would be needed.

[Kilroy]

Thanks again Paul. This will come in handy as well. But really what I'm looking for is a macro that will move all types of shapes and pictures to a new document. I already have the one above to remove tables and another that removes watermarks and hyperlinks. It's shapes and pictures that I still need remove. I don't want to just delete if it's possible as occasionally I need to add some of them back after processing the document.

[macropod]

As I have already said, if all you want is a document with just the shapes and pictures in a new document, simply make a copy of the original and do a Find/Replace with:

Find = ^?
Replace = nothing
Did you at least try that?

[Kilroy]

Thanks Paul. Yes I did try that and it does work but what I'm looking for is a macro that removes all shapes and pictures to a new document. I have a number of other macros that run previous and after this. The reason I need to move as opposed to delete what I don't want is that I also need to further process that document as well. Sorry I wasn't very clear on that.

[macropod]

Unless you have particular locations where all theses pics are to go, then do as I suggested and then copy what's left to your new document. If you do
have particular locations where all theses pics are to go, then you're going to have to provide a whole lot more detail.

[Kilroy]

thanks Paul, new document would need to go to the same folder as original with an " _shapes.docx" extension.

[macropod]

Locations as in locations in the new document; otherwise:

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document
Set DocSrc = ActiveDocument
Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False)
With DocTgt
.FormattedText = DocSrc.Range.FormattedText
With .Range
.FormattedText = DocSrc.Range.FormattedText
While .Tables.Count > 0
.Tables(1).Delete
Wend
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End With
.SaveAs2 FileName:=Split(DocSrc.FullName, ".doc")(0) & " _shapes.docx", _
Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

[Kilroy]

Thanks Paul it's getting hung up on ".FormattedText = DocSrc.range.FormattedText" The fist one following "With DocTgt"

[Kilroy]

Paul I commented out that line and the table lines and it's working as far as moving tables with no text and is copying shapes to the new document but is not deleting them.



Sub CopyShapesAndPicturesToANewDoc()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document
Set DocSrc = ActiveDocument
Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False) 'True)
With DocTgt
' .FormattedText = DocSrc.range.FormattedText
With .range
.FormattedText = DocSrc.range.FormattedText
'While .Tables.Count > 0
'.Tables(1).Delete
'Wend
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceAll
End With
End With
.SaveAs2 FileName:=Split(DocSrc.FullName, ".doc")(0) & " _shapes.docx", _
Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
.Close False
End With
Set DocTgt = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub

[macropod]

Commenting-out that line should result in the macro doing nothing other than creating a new, empty, document and saving it. In any event, the code is written to generate a document containing just the shapes. You might be able to get the desired result, though, by changing:
Set DocTgt = Documents.Add(Template:=DocSrc.AttachedTemplate.FullName, Visible:=False)
to:
Set DocTgt = Documents.Add(Template:=DocSrc.FullName, Visible:=False)
and omitting:
.FormattedText = DocSrc.range.FormattedText

[Kilroy]

Change made thanks Paul working great.