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 sEnd 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.
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 sEnd Sub
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"
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.CreateSelectionEnd 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.CreateSelectionEnd Sub
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.
I'll find a way to compensate you for your time.
Please, no need. It is my pleasure.
Glad to help.