Changing the fill and line color of selected elements using VBA

Started by ruben302, May 12, 2021, 07:25:49 AM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

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

Quote from: ruben302 on May 12, 2021, 07:25:49 AMbut this does not work on a grouped shape
Hi, Ruben !
You mean that this code dont works with sub-shapes into group shape ?

ruben302

Quote from: Surrogate on May 12, 2021, 07:37:40 AM
Quote from: ruben302 on May 12, 2021, 07:25:49 AMbut 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
Quote from: Surrogate on July 26, 2013, 01:43:57 PM
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

Quote from: ruben302 on May 12, 2021, 07:59:16 AM
how would I encorporate my code into this?
Sorry ! My previous code not so obvious...
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:

Quoteshp.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

Quote from: ruben302 on May 12, 2021, 09:10:54 AM
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

Quote from: ruben302 on May 12, 2021, 09:30:13 AM
I want the script to skip the GUARDed cells.
OK, try check is formula in cell contain "GUARD" ? just change these rows 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

Quote from: Surrogate on May 12, 2021, 10:15:38 AM
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  :o

Surrogate

Try this changes again ! Check is formula in cell do not started with GUARD
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)"