How to delete color information from shape

[RandomGerman]

Hello,

I have written a macro to get rid of fill colors very quickly, working with


oshp.Fill.Visible = msoFalse

But this is not the same as clicking "no fill" in the coloring menu. With "no fill" in the coloring menu, one really deletes the color information, while it is still there, when I use "Visible = false"

How can I really get rid of the color information? I tried


oshp.Fill.ForeColor.RGB = msoFalse

but that's just a black shape, setting RGB to 0, 0, 0.

Intention is to get completely rid of the coloring information, because I have a different macro, searching for shapes with the same color as a selected shape. It works well with one exception: It selects shapes with invisible fills of the same color, too.

It is probably just one line, but I have no idea yet.

[Paul_Hossler]

I'm not sure that there's any way to get rid of the color information.


Intention is to get completely rid of the coloring information, because I have a different macro, searching for shapes with the same color as a selected shape. It works well with one exception: It selects shapes with invisible fills of the same color, too

Could you add a test to see if it's visible?

[John Wilson]

AFAIK there is no way in vba to set the XML for a shape to noFill.

Could you maybe set to a weird fill like RGB(1,1,1) and set the fill to not visible

[RandomGerman]

To make the problem visible, please see the attached file. I inserted both macros and put a few shapes onto the slide. The problem shape is Shape 2. It should match with Shape 1, as it seems to have no fill, but it matches with Shape 3, 4 and 5, as in fact it has an (invisible) blue fill.

John's idea with changing RGB (1,1,1) and then making this invisible would solve one half of the problem: Shape 2 would not match any longer with Shape 3, 4 and 5. But it still would not match with Shape 1. Shape 1 really has no fill. I deleted the fill of Shape 1 by using No Fill from the coloring menu, not by using the no-fill-macro.

I was hoping for something like, e.g., oshp.Fill.ForeColor.Delete (which is not the solution)

Thank you!

[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

29560


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

[RandomGerman]

This is awesome, Paul, thank you so much!

[Paul_Hossler]

I hope it works for you

Personal opinion: I've found that using arrays instead of collections gives me a little more control (or at least fewer opportunities to make errors)

[RandomGerman]

I don't have a lot of confidence when I code with arrays or collections, because I'm not good with it. It's a lot of trial and error, so I'm always relieved when I find a solution by myself (which does not happen everytime) that works halfway. This was the case, but of course your solution is a great improvement, because now it works far better than only halfway. ;-)
I have a second version of the tool selecting by shape type, and it was easy to adapt your array solution to that one.

Again: Thank you very much!

[Paul_Hossler]

snb has a nice writeup on arrays

https://www.snb-vba.eu/VBA_Arrays_en.html

As an aside, it the PP macro I used Redim Preserve on the dynamic array which just 'adjusts' the array size so that it could be passed to Range(..)

Depending on how it will be used, I also sometimes will Dim a fixed array and use a counter






Dim Ary(1 to 1000) as long
dim cntAry as long

cntAry = 0

...
...
...
...

cntAry = cntAry + 1
Ary(cntArt) = 12345

...
...
...

LastVal = Ary(cntAry)

[RandomGerman]

Wow, cool. I'm curious, if I'll get better in using arrays with this. Thank you so much, Paul!