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!
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 ?
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.
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 (http://visguy.com/vgforum/index.php?action=profile;u=11946) for recursion macro :)
Thanks! my VBA knowledge is however very limited, how would I encorporate my code into this?
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 (http://visguy.com/vgforum/index.php?topic=1173.msg37886#msg37886) (wrapped in *) and #2 (http://visguy.com/vgforum/index.php?topic=1173.msg37893#msg37893) (wrapped in **) and add your own code (http://visguy.com/vgforum/index.php?topic=9558.msg42730#msg42730) (wrapped in ***)
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)
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 ?
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.
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)"
Thanks for your reply, however I can't get it to work, see updated attached file
edit:correct file attached
Sorry, I am Russian :)
You need make shape marked as Original like as shape marked as Desired ?
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.
My bad ! Some shapes have (http://themeguard) in their cells, this is reason why my code dont work correct :o
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)"
Wow! it works! thanks a lot! you are awesome!
For the curious, wrt recursive loops, see this post: http://visguy.com/vgforum/index.php?topic=7286.msg30645#msg30645 (http://visguy.com/vgforum/index.php?topic=7286.msg30645#msg30645)