Consulting

Results 1 to 5 of 5

Thread: Solved: Adding shapes to current selection

  1. #1
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location

    Solved: Adding shapes to current selection

    I'm trying to simulate a "magic wand" effect on shapes in PowerPoint. I want my macro to select any shape on the current slide that matches the currently selected shape's fill color.

    Here's my code:
    [vba]
    'Fill Color
    If cb_FillColor = True Then
    myFillColor = ActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Fill.ForeColor.RGB = myFillColor Then
    shp.Select
    End If
    Next
    End If
    [/vba]

    However, it's not making the selection add to itself. It's just looping through the shapes one by one and ending on the last one that matches the criteria. Is there a way to ADD to a selection as I loop through the shapes?

    FYI: cb_FillColor is the checkbox name on a form I'm using.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  2. #2
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    I figured it out. In case anyone wants to know the same thing, here's my fix:
    [vba]
    'Fill Color
    If cb_FillColor = True Then
    myFillColor = ActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Fill.ForeColor.RGB = myFillColor Then
    shp.Select Replace:=False
    End If
    Next
    End If
    [/vba]

    Once I'm all done with my macro I will post it.
    Office 2010, Windows 7
    goal: to learn the most efficient way

  3. #3
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    ugh... I wish we could UNSOLVE posts.

    I have another problem. It seems to be selecting any shape that uses the default color as well as the currently selected shape's fill color. Is there any way to fix this? It works fine if the shape is any other color, but if it's the default color, it's selecting things that don't have a fill color at all. Very strange.
    [vba]
    'Fill Color
    If cb_FillColor = True Then
    myFillColor = ActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Fill = msoTrue Then
    If shp.Fill.ForeColor.RGB = myFillColor Then
    shp.Select Replace:=False
    End If
    End If
    Next
    End If
    [/vba]
    Office 2010, Windows 7
    goal: to learn the most efficient way

  4. #4
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Why do I always find the solution to my question like 5 minutes after I make the post? This is a terrible habit I'm making.

    This fixed my problem.
    [vba]
    'Fill Color
    If cb_FillColor = True Then
    myFillColor = ActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    'If ActiveWindow.Selection.ShapeRange.Fill.Visible = msoFalse Then
    If shp.Fill.Visible = msoFalse Then
    Resume Next
    ElseIf shp.Fill.ForeColor.RGB = myFillColor Then
    shp.Select Replace:=False
    End If
    Next
    End If
    [/vba]
    Office 2010, Windows 7
    goal: to learn the most efficient way

  5. #5
    VBAX Expert TrippyTom's Avatar
    Joined
    Jul 2005
    Location
    New York, NY (USA)
    Posts
    556
    Location
    Ok, below is my final code. I made a userform that looks like the attached picture. I made them option buttons because if the user chose more than one it would produce strange results.
    [vba]
    Sub MagicWand()
    'simulates the Magic Wand tool in Adobe Illustrator to select shapes with similar:
    'Fill color, Line color, Line weight, Font color, or Opacity
    frm_MagicWand.Show
    End Sub
    [/vba]
    This is the code on the form itself:
    [vba]
    Private Sub btn_All_Click()
    cb_FillColor = True
    cb_LineColor = True
    cb_LineWeight = True
    cb_Opacity = True
    cb_FontColor = True
    End Sub
    Private Sub btn_Cancel_Click()
    Unload Me
    End Sub
    Private Sub btn_None_Click()
    cb_FillColor = False
    cb_LineColor = False
    cb_LineWeight = False
    cb_Opacity = False
    cb_FontColor = False
    End Sub
    Private Sub btn_OK_Click()
    On Error Resume Next
    Dim myFillColor As Variant
    Dim myLineColor As Variant
    Dim myLineWeight As Variant
    Dim myFontColor As Variant
    Dim myOpacity As Variant
    Dim shp As Shape
    Dim mySlide As Integer
    mySlide = ActiveWindow.View.Slide.SlideIndex
    'Fill Color
    If op_FillColor = True Then
    myFillColor = ActiveWindow.Selection.ShapeRange.Fill.ForeColor.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Fill.Visible = msoFalse Then
    Resume Next
    ElseIf shp.Fill.ForeColor.RGB = myFillColor Then
    shp.Select Replace:=False
    End If
    Next
    End If
    'Line Color
    If op_LineColor = True Then
    myLineColor = ActiveWindow.Selection.ShapeRange.Line.ForeColor.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Line.Visible = msoFalse Then
    Resume Next
    ElseIf shp.Line.ForeColor.RGB = myLineColor Then
    shp.Select Replace:=False
    End If
    Next
    End If
    'Line Weight
    If op_LineWeight = True Then
    myLineWeight = ActiveWindow.Selection.ShapeRange.Line.Weight
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Line.Visible = msoFalse Then
    Resume Next
    ElseIf shp.Line.Weight = myLineWeight Then
    shp.Select Replace:=False
    End If
    Next
    End If
    'Opacity
    If op_Opacity = True Then
    myOpacity = ActiveWindow.Selection.ShapeRange.Fill.Transparency
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If shp.Fill.Visible = msoFalse Then
    Resume Next
    ElseIf shp.Fill.Transparency = myOpacity Then
    shp.Select Replace:=False
    End If
    Next
    End If
    'Font Color
    If op_FontColor = True Then
    myFontColor = ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Color.RGB
    For Each shp In ActivePresentation.Slides(mySlide).Shapes.Range
    If Not shp.HasTextFrame Then
    Resume Next
    ElseIf shp.TextFrame.TextRange.Font.Color.RGB = myFontColor Then
    shp.Select Replace:=False
    End If
    Next
    End If

    Unload Me
    End Sub
    [/vba]
    Office 2010, Windows 7
    goal: to learn the most efficient way

Posting Permissions

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