Consulting

Results 1 to 14 of 14

Thread: Shapes

  1. #1
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location

    Shapes

    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
    Last edited by Kilroy; 08-14-2018 at 12:02 PM.

  2. #2
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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).
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  3. #3
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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.

  4. #4
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    In your first post, you said:
    Quote Originally Posted by Kilroy View Post
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  5. #5
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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.

  6. #6
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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?
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  7. #7
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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.

  8. #8
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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.
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  9. #9
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    thanks Paul, new document would need to go to the same folder as original with an " _shapes.docx" extension.

  10. #10
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  11. #11
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    Thanks Paul it's getting hung up on ".FormattedText = DocSrc.range.FormattedText" The fist one following "With DocTgt"

  12. #12
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    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

  13. #13
    Knowledge Base Approver VBAX Guru macropod's Avatar
    Joined
    Jul 2008
    Posts
    4,435
    Location
    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
    Cheers
    Paul Edstein
    [Fmr MS MVP - Word]

  14. #14
    VBAX Tutor
    Joined
    Jul 2016
    Posts
    266
    Location
    Change made thanks Paul working great.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •