Changing the fill and line color of selected elements using VBA

[ruben302]

Hi everyone!

I am trying to mimick (using a macro) of applying a fill and line color on selected shapes, (see screenshot).

I have the following vba code, that allows me to change the fill and line color of a singular shape, but this does not work on a grouped shape. This also does not work with undo (ctrl+z), like applying a color does.

Sub changeColor()
Dim shp As Visio.Shape
For Each shp In ActiveWindow.Selection
shp.Cells("FillForegnd").FormulaForceU = "RGB(255, 255, 0)"
shp.Cells("FillBkgnd").FormulaForceU = "RGB(255, 255, 0)"
shp.Cells("LineColor").FormulaForceU = "RGB(255, 255, 0)"
Next
End Sub

Thanks in advance!

[Surrogate]

but this does not work on a grouped shape

Hi, Ruben !
You mean that this code dont works with sub-shapes into group shape ?

[ruben302]

but this does not work on a grouped shape

Hi, Ruben !
You mean that this code dont works with shapes into group shape ?

Hi! Yes!

Let's say i have a shape and a group of two shapes (see screenshot). I want to also change the colour of all the shapes inside the group with the macro.

[Surrogate]

You need add recursion: something like this

Code

Sub a()
    Dim sh As Visio.Shape
    Dim pg As Visio.Page
    Dim coll As New Collection
 
    For Each pg In ThisDocument.Pages
        For Each sh In pg.Shapes
            If sh.Shapes.Count > 0 Then
                Recursion sh.Shapes, coll
            End If
            coll.Add sh
        Next sh
    Next pg
    For Each sh In coll
        sh.CellsSRC(visSectionObject, visRowMisc, visNonPrinting).FormulaForceU = "False"
    Next sh
End Sub
Sub Recursion(ByVal shps As Visio.Shapes, coll As Collection)
    Dim sh As Visio.Shape
    For Each sh In shps
        If sh.Shapes.Count > 0 Then
            Recursion sh.Shapes, coll 'çäåñü ïðîèñõîäèò âûçîâ ñàìîé ñåáÿ
        End If
        coll.Add sh
    Next sh
End Sub

Thanks to 9rey for recursion macro

[ruben302]

Thanks! my VBA knowledge is however very limited, how would I encorporate my code into this?

[Surrogate]

how would I encorporate my code into this?

Sorry ! My previous code not so obvious…

Code

Sub Main()
' ** I borrowed this part of the code at http://visguy.com/vgforum/index.php?topic=1173.msg37893#msg37893
Dim vsoSelect As Visio.Selection
Dim vsoShape As Visio.Shape
Dim vsoShapes As Visio.Shapes
Set vsoSelect = Visio.ActiveWindow.Selection
If vsoSelect.Count > 0 Then
    For Each vsoShape In vsoSelect
        Call changeColor(vsoShape)
    Next vsoShape
Else
    MsgBox "You Must Have Something Selected"
End If
MsgBox "TheEnd!!!"
' **
End Sub
Public Sub changeColor(shp As Visio.Shape)
' *** I borrowed this part of the code at http://visguy.com/vgforum/index.php?topic=9558.msg42730#msg42730
shp.Cells("FillForegnd").FormulaForceU = "RGB(255, 255, 0)"
shp.Cells("FillBkgnd").FormulaForceU = "RGB(255, 255, 0)"
shp.Cells("LineColor").FormulaForceU = "RGB(255, 255, 0)"
' ***
' * I borrowed this part of the code at http://visguy.com/vgforum/index.php?topic=1173.msg37886#msg37886
Dim subshp As Visio.Shape
If shp.Shapes.Count > 0 Then
    For Each subshp In shp.Shapes
        Call changeColor(subshp)
    Next subshp
End If
End Sub
' *

to write this code, I took the snippets in these posts: #1 (wrapped in *) and #2 (wrapped in **) and add your own code (wrapped in ***)

[ruben302]

Wow thanks a lot! this works already!

I only have one problem still:

some shapes inside my group are GUARDed so ideally i would use:

shp.Cells("FillForegnd").FormulaU = "RGB(255, 255, 0)"
shp.Cells("FillBkgnd").FormulaU = "RGB(255, 255, 0)"
shp.Cells("LineColor").FormulaU = "RGB(255, 255, 0)"

to not overrule the GUARD, but this returns an error, see attached file (or screenshot)

[Surrogate]

to not overrule the GUARD, but this returns an error, see attached file (or screenshot)

when you use FormulaU and try change formula in cell which protected with GUARD you get error, because FormulaU cant change this cell !
you sure that you need try change these cells ?

[ruben302]

i don't want to update the GUARD protected cells, only the unprotected cells. but the script stops when it comes across the first GUARDed cell

I want the script to skip the GUARDed cells.

[Surrogate]

I want the script to skip the GUARDed cells.

OK, try check is formula in cell contain "GUARD" ? just change these rows

Code

If InStr(shp.Cells("LineColor").FormulaU, "GUARD") = 0 Then shp.Cells("LineColor").FormulaU = "RGB(255, 255, 0)"
If InStr(shp.Cells("FillForegnd").FormulaU, "GUARD") = 0 Then shp.Cells("FillForegnd").FormulaU = "RGB(255, 255, 0)"
If InStr(shp.Cells("FillBkgnd").FormulaU, "GUARD") = 0 Then shp.Cells("FillBkgnd").FormulaU = "RGB(255, 255, 0)"

[ruben302]

Thanks for your reply, however I can't get it to work, see updated attached file

edit:correct file attached

[Surrogate]

Sorry, I am Russian
You need make shape marked as Original like as shape marked as Desired ?

[ruben302]

Sorry, I am Russian
You need make shape marked as Original like as shape marked as Desired ?

No problem, I am grateful for your help! Yes you are correct. the black shape with star marked as original using VBA to the yellow shaped marked as desired.

[Surrogate]

My bad ! Some shapes have in their cells, this is reason why my code dont work correct 

[Surrogate]

Try this changes again ! Check is formula in cell do not started with GUARD

Code

If Not InStr(shp.Cells("LineColor").FormulaU, "GUARD") = 1 Then shp.Cells("LineColor").FormulaU = "RGB(255, 255, 0)"
If Not InStr(shp.Cells("FillForegnd").FormulaU, "GUARD") = 1 Then shp.Cells("FillForegnd").FormulaU = "RGB(255, 255, 0)"
If Not InStr(shp.Cells("FillBkgnd").FormulaU, "GUARD") = 1 Then shp.Cells("FillBkgnd").FormulaU = "RGB(255, 255, 0)"