macro to find objects

so I've recorded a macro to find all drop shadows and seperate them from whatever they're attached to. Now my problems is how to deselect the objects leaving just the drop shadows selected

Sub Macro173()
    ActiveDocument.CreateShapeRangeFromArray(ActiveLayer.Shapes(3), ActiveLayer.Shapes(1)).Cut
    ActiveLayer.Paste
    Dim Paste1 As ShapeRange
    Set Paste1 = ActiveSelectionRange
    ActiveDocument.Undo
    ActiveDocument.Undo
    ActivePage.Shapes.All.CreateSelection
    ActiveSelection.Separate
  
 
End Sub

  • Hi.

    It's simple but it should work.

    Try it:

     

    Sub findMyDrops()
        Dim s As Shape, sr As ShapeRange
       
        Set sr = ActivePage.Shapes.All
       
        For Each s In sr
            On Error Resume Next
            If s.Effect.Type = cdrDropShadow Then
                If Err.Number = 0 Then s.BreakApart
            End If
            On Error GoTo 0
        Next s
    End Sub

     

     

    ~John

    • doesn't work for X3. I'll try it tomorrow on X4.

      My ultimate goal would be to have the drop shadows separated, converted to RGB 150dpi w/transparent background.

      I use a pdf template to proof layouts to clients. I just copy what I want to show them paste it onto the 8.5 x 11 template and size it to fit onto the page. If I publish to pdf  with the drop shadows it's quite large but if I break them apart and convert them to RGB blah blah blah it cuts the file size down quite a bit.

      If I have a layout that uses multiple drop shadows it can take some time to separate them all. You know like 2minutes. LOL. Too slow for me.

      • Hi.

        This one should work in X3:

         

        Sub findMyDrops()
            Dim s As Shape, sr As ShapeRange
            Dim e As Effect
           
            Set sr = ActivePage.Shapes.All
          
            For Each s In sr
                Set e = s.Effect
                If Not e Is Nothing Then
                    If e.Type = cdrDropShadow Then
                        e.Separate
                    End If
                End If
            Next s
        End Sub

         

        ~John

        • works perfectly in X4. It finds and seperates all drop shadows on the page.

          Next would be to do another "query" to select all those drop shadows which are now "transparencies" or "lens"

          • Hi.

            This should select them when finished.

             

            Sub findMyDrops()
                Dim s As Shape, sr As ShapeRange
                Dim e As Effect, sr2 As ShapeRange, srFinal As New ShapeRange
              
                Set sr = ActivePage.Shapes.All
             
                For Each s In sr
                    Set e = s.Effect
                    If Not e Is Nothing Then
                        If e.Type = cdrDropShadow Then
                            Set sr2 = e.Separate
                            srFinal.Add sr2.FirstShape
                        End If
                    End If
                Next s
                srFinal.CreateSelection
            End Sub

             

            This should just select them in case you already separated:

             

            Sub selectMyDrops()
                Dim s As Shape, sr As ShapeRange
                Dim e As Effect, srFinal As New ShapeRange
              
                Set sr = ActivePage.Shapes.All
             
                For Each s In sr
                    If s.Transparency.Type = cdrPatternTransparency Then srFinal.Add s
                Next s
                srFinal.CreateSelection
            End Sub

             

            ~John

            • Okay, those work great. Got other issues with rasterizing them to bitmap but I can deal with it. Thanks a lot. I'll find a way to compensate you for your time.

              • Myron said:

                I'll find a way to compensate you for your time.

                Please, no need. It is my pleasure.

                Glad to help.

                ~John