Thread: code request
View Single Post
  #3  
Old 15-12-2016, 13:03
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,782
Blog Entries: 11
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Select Effects

Here you go, select your shape or shapes and run the SelectEffects
Code:
Sub SelectEffects()
    Dim sr As ShapeRange, srNewSelection As New ShapeRange
    Dim s As Shape
    Dim eff As Effect
    
    Set sr = ActiveSelectionRange
    
    For Each s In sr.Shapes
        If s.Effects.Count > 0 Then
            AddShape srNewSelection, s
        Else
            srNewSelection.Add s
        End If
    Next s
    
    srNewSelection.CreateSelection
End Sub

Private Sub AddShape(ByVal sr As ShapeRange, ByVal s As Shape)
    Dim eff As Effect
    Dim eff2 As Effect
    
    If s Is Nothing Then Exit Sub
    If sr.IndexOf(s) <> 0 Then Exit Sub
    sr.Add s
    
    For Each eff In s.Effects
        AddEffect sr, eff
    Next eff
End Sub

Private Sub AddEffect(ByVal sr As ShapeRange, ByVal eff As Effect)
    Dim eff2 As Effect
    
    Select Case eff.Type
        Case cdrTextOnPath
            AddShape sr, eff.TextOnPath.Path
        Case cdrExtrude
            AddShape sr, eff.Extrude.BevelGroup
            AddShape sr, eff.Extrude.ExtrudeGroup
        Case cdrDropShadow
            AddShape sr, eff.DropShadow.ShadowGroup
        Case cdrControlPath
            For Each eff2 In eff.ControlPath.Effects
                AddEffect sr, eff2
            Next eff2
        Case cdrContour
            AddShape sr, eff.Contour.ContourGroup
        Case cdrBlend
            AddShape sr, eff.Blend.BlendGroup
            AddShape sr, eff.Blend.StartShape
            AddShape sr, eff.Blend.EndShape
            AddShape sr, eff.Blend.Path
    End Select
End Sub
Reply With Quote