How to delete color information from shape

[Paul_Hossler]

I think the issue was a logic error in the code

I changed to an array since it's easier to track

Not .Fill.Visible seems to work

Even with the macro that was working I kept getting an extra shape selected (possibly caused by using a collection??) - Look at Shape 2

Capture.JPG


This is a little wordy, but I like to be very specific defining If/Then tests and not try to squeeze it into a single logical statement with lots or ANDs and ORs

Option Explicit


Sub SelectByColor()
    Dim shpSelected As Shape
    Dim shp As Shape
    Dim aryShapes() As Long
    Dim i As Long
   
    If ActiveWindow.Selection.Type <> ppSelectionShapes And ActiveWindow.Selection.Type <> ppSelectionText Then
        MsgBox "Please select a shape"
        Exit Sub
    End If
    
    If ActiveWindow.Selection.ShapeRange.Count > 1 Then
        MsgBox "Please select only one shape"
        Exit Sub
    End If


    Set shpSelected = ActiveWindow.Selection.ShapeRange(1)


    If shpSelected.Type = msoPicture Or shpSelected.AutoShapeType = msoShapeMixed Then
        MsgBox "Sorry! For pictures and lines or connectors no fill color is defined"
        Exit Sub
    End If


    ReDim aryShapes(0 To 0)
        
    For i = 1 To ActiveWindow.Selection.SlideRange.Shapes.Count
        Set shp = ActiveWindow.Selection.SlideRange.Shapes(i)
        
        With shp
            
            If .Type = msoPicture Then GoTo NextShape
            If Not .Visible Then GoTo NextShape
            If Not .Fill.Visible And shpSelected.Fill.Visible Then GoTo NextShape
            If .Fill.Visible And Not shpSelected.Fill.Visible Then GoTo NextShape
            
            If Not .Fill.Visible And Not shpSelected.Fill.Visible Then
                aryShapes(UBound(aryShapes)) = i
                ReDim Preserve aryShapes(0 To UBound(aryShapes) + 1)
                GoTo NextShape
            End If
            
            If .Fill.ForeColor = shpSelected.Fill.ForeColor Then
                aryShapes(UBound(aryShapes)) = i
                ReDim Preserve aryShapes(0 To UBound(aryShapes) + 1)
                GoTo NextShape
            End If
        End With
NextShape:
    Next i


    If UBound(aryShapes) = 0 Then
        MsgBox "No matching shape found"
    Else
        ReDim Preserve aryShapes(0 To UBound(aryShapes) - 1)
        ActiveWindow.Selection.Unselect
        ActiveWindow.Selection.SlideRange(1).Shapes.Range(aryShapes).Select
    End If
    
End Sub

To remove all fills

Sub RemoveFills()    Dim oShape As Shape
    
    For Each oShape In ActivePresentation.Slides(1).Shapes
        oShape.Fill.Visible = msoFalse
    Next


End Sub