Color-code an org Chart based on Boxes values

Started by glaffitte, March 02, 2016, 05:54:39 PM

Previous topic - Next topic

0 Members and 1 Guest are viewing this topic.

Nikolay

I believe it is just Visio 2013 org chart shapes are different (Microsoft guys updated them to look more modern in Visio 2013)
Probably Visio 2013 should prompt you to update shapes on opening diagram. To see the original macro working, answer NO.
I think , unlike Visio 2007 or 2010 you may need to set background on a different (child) shape (not on the same shape where you have the data property) in Visio 2013. Try using the drawing explorer to see the shape structure.

brycentonic

You nailed it. Shape data is different. Enabling the Developer options let me see the different information. I was thinking that Prop.Alocation was a general call and not looking for a cell with the "Alocation" property. Looking at the shape data is showing me more, but it's still skipping right past the THEN piece.



Sub TestLocal()
Dim pg As Page
Dim sh As Shape
For Each pg In ActiveDocument.Pages
For Each sh In pg.Shapes
    If sh.CellExists("Prop.JOB_NAME", visExistsAnywhere) Then
         If sh.Cells("Prop.JOB_NAME").FormulaU = """Contractor""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
    End If
   
    If sh.CellExists("Prop.SPECIAL_GROUP", visExistsAnywhere) Then
         If sh.Cells("Prop.SPECIAL_GROUP").FormulaU = """XYZ TV""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
    End If

Next
Next
End Sub


(Not worried about colors or the actions until I get the logic final to make the changes in the right places.)

wapperdude

I don't see anything inherently wrong with the code.  It seems to work fine on Visio2007.  One thing to noted, when using ".Cells" type call, the entry has to be perfectly identical to the cell in question, i.e., spelling, spaces, upper / lower cases.

I'm enclosing some code that has some syntax variations.  I prefer using ".Results" rather than ".Formula" for comparing cell contents.  I think of "Formula" for stuffing into the cell and "Result" as fetch from what's inside the cell.  But as noted, both seem to work in  this case.


Sub ExistNChng()
'Note, using ".Cells" requires that the cell name be in quotes, spelled perfectly correct,
'including any upper / lower case conditions.

    Dim vsoShp As Shape
   
    For Each vsoShp In ActivePage.Shapes
        If vsoShp.CellExists("Prop.RowName", visExistsAnywhere) Then
            Debug.Print vsoShp.CellsRowIndex("Prop.RowName") & "  " & vsoShp.Cells("Prop.RowName").ResultStr(visNone)  'Diagnostic output

'There are several ways / formats to fetch content of a cell, all of these work:
'            If vsoShp.Cells("Prop.RowName").Formula = """Inspection""" Then
'            If vsoShp.Cells("Prop.RowName").Formula = Chr(34) & "Inspection" & Chr(34) Then
'
' While the above two constructs work, I prefer the following.  I tend to think of "Formula" as entering
' values into a cell, and "Result" as fetching value from a cell.
' Breaking the "coloring" IF statement into a more traditional look, improves readability.
'
            If vsoShp.Cells("Prop.RowName").ResultStr(visNone) = "Inspection" Then
                vsoShp.Cells("Fillforegnd").Formula = "RGB(255,255,0)"
            End If
        End If
    Next

End Sub
Visio 2019 Pro

wapperdude

If you're still having problems, perhaps you can upload a Visio file with one of the misbehaving shapes.  I need it in older vex format.  Otherwise, someone else will need to take a look.

Wapperdude
Visio 2019 Pro

brycentonic

Well... I am happy and sad at the same time. Your insistence that it worked for YOU had me digging into the shape data trying to figure out where my problem is.

The GOOD news is that the Macro is changing the shape data color. The BAD news, is that the visual depiction of that color is not updating. When I look at the shape, it SHOWS Color as Red even when the shape isn't red. If I manually change the transparency of the color... the red IS there. In the attached file, if you look at the grey and purple shapes on the first tab... the SHAPE color of those is red.

So the color IS getting changed for the shape... but it's not reflecting in the actual color displayed.

"Working" macro
   
Sub Test2()
Dim pg As Page
Dim sh As Shape
For Each pg In ActiveDocument.Pages
For Each sh In pg.Shapes
    If sh.CellExists("Prop.JOB_NAME", visExistsAnywhere) Then
         If sh.Cells("Prop.JOB_NAME").Formula = """Contractor""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
    End If
   
    If sh.CellExists("Prop.SPECIAL_GROUP", visExistsAnywhere) Then
         If sh.Cells("Prop.SPECIAL_GROUP").Formula = """XYZ TV""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
    End If



Next
Next
End Sub


(The XYZ TV isn't working in the file attached as I found a problem with the formatting where there are two spaces after TV. Fixing that now. Still having the problem where the shape color changes but isn't updated.)

wapperdude

BTW, vsdx format not readable by V2007.  Need plan ol' vsd.
Visio 2019 Pro

brycentonic


wapperdude

Yes, indeed, I was able to replicate the problem.  The shape(s) in question are grouped shapes.  When you select the shape and change the color via the GUI, all of the subshapes inherit the color change.  However, when you do it by code, only the shape selected by code is changed, the subshapes do not inherit the change.

You can run the macro recorder to get an idea of what the GUI is doing.  For example, sheet.188, is a candidate for color change.  The code does change sheet.188 fill foreground.  But the shape remains unchanged.  That's because, it's like, 3 buried subshapes down that needs the actual change.  To wit: 
    ActiveWindow.Page.Shapes.ItemFromID(188).Shapes.ItemFromID(189).Shapes.ItemFromID(190).Shapes.ItemFromID(192).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(255,255,0))"  This is the line that causes the appearance to change to yellow in this case.

So, once shape.188 or any other candidate is selected, then a recursive algorithm must be run to get to the "bottom of things".  Unfortunately, I must be off.  Probably can get to this tomorrow if you need help.  There ought to be a recursive piece of code on the forum.

Wapperdude

Visio 2019 Pro

brycentonic

Sure enough... the color change effects a large number of cells.

Output from the Macro recording for coloring a cell.
Application.ActiveWindow.Page.Shapes.ItemFromID(206).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(146,208,80))"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(146,208,80))"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(211).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(211).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(211).Shapes.ItemFromID(213).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(211).Shapes.ItemFromID(213).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(211).Shapes.ItemFromID(212).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(211).Shapes.ItemFromID(212).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(146,208,80))"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(210).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(146,208,80))"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(210).CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(210).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(210).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(209).CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "THEMEGUARD(RGB(146,208,80))"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(209).CellsSRC(visSectionObject, visRowFill, visFillPattern).FormulaU = "1"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(209).CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaU = "FALSE"
    Application.ActiveWindow.Page.Shapes.ItemFromID(206).Shapes.ItemFromID(207).Shapes.ItemFromID(208).Shapes.ItemFromID(209).CellsSRC(visSectionObject, visRowGradientProperties, visRotateGradientWithShape).FormulaU = "FALSE"
    Application.EndUndoScope UndoScopeID12, True


Will see what I can find for recursive code to address all grouped shapes.

wapperdude

Borrowed recursive from Surrogate,

This code should work.  I made XYZ TV an alternate color, can be eliminated.  Also, code eliminates 1D shapes from testing.


Sub Test2()
    Dim pg As Page
    Dim sh As Shape

    For Each pg In ActiveDocument.Pages
        For Each sh In pg.Shapes
            If Not (sh.OneD) Then
                If sh.CellExists("Prop.JOB_NAME", visExistsAnywhere) Then
                    If sh.Cells("Prop.JOB_NAME").ResultStr(visNone) = "Contractor" Then
'                        sh.Cells("Fillforegnd").Formula = RGB(48, 20, 237)
                        Call MainShapes(sh.Shapes)
                    End If
                End If
           
                If sh.CellExists("Prop.SPECIAL_GROUP", visExistsAnywhere) Then
                     If sh.Cells("Prop.SPECIAL_GROUP").ResultStr(visNone) = "XYZ TV" Then
'                        sh.Cells("Fillforegnd").Formula = RGB(48, 20, 237)
                        Call MainShapes(sh.Shapes)
                    End If
                End If
            End If
        Next
    Next
End Sub

Sub MainShapes(shps As Visio.Shapes)
    Dim sh As Shape
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
                On Error Resume Next
                sh.Cells("Fillforegnd").Formula = RGB(48, 20, 237)
                If sh.Cells("Prop.SPECIAL_GROUP").ResultStr(visNone) = "XYZ TV" Then
                        sh.Cells("Fillforegnd").FormulaU = RGB(237, 255, 0)
                End If
        End If
        MainShapes sh.Shapes
    Next sh
End Sub


It appears there are some issues with the shapes.  Didn't dig into that.

Wapperdude
Visio 2019 Pro

wapperdude

#25
Found couple of errors in the above code, here's corrected.  Everything seems to work as desired.  Forget previous comment about problems with the shapes, it was with the code.


Sub Test2()
    Dim pg As Page
    Dim sh As Shape
    Dim newColor As String

    For Each pg In ActiveDocument.Pages
        For Each sh In pg.Shapes
            If Not (sh.OneD) Then           
                If sh.CellExists("Prop.JOB_NAME", visExistsAnywhere) Then
                    If sh.Cells("Prop.JOB_NAME").ResultStr(visNone) = "Contractor" Then
                        newColor = "RGB(150, 150, 237)"
                        Call MainShapes(sh.Shapes, newColor)
                    End If
                End If
           
                If sh.CellExists("Prop.SPECIAL_GROUP", visExistsAnywhere) Then
                     If sh.Cells("Prop.SPECIAL_GROUP").ResultStr(visNone) = "XYZ TV" Then
                        newColor = "RGB(255, 255, 0)"
                        Call MainShapes(sh.Shapes, newColor)
                    End If
                End If
            End If
        Next
    Next
End Sub

Sub MainShapes(shps As Visio.Shapes, nClr As String)
    Dim sh As Shape
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
                On Error Resume Next
                sh.Cells("Fillforegnd").Formula = nClr
        End If
        MainShapes sh.Shapes, nClr
    Next sh
End Sub


wapperdude
Visio 2019 Pro

brycentonic

That is indeed working great! Thank you. Making some updates for the couple other items that she wants for the automated formatting. THANK YOU.

(And of course now she asks for some wildcarding of the Prop.Special_Group fields. HUGE amount of progress, thank you.)

brycentonic

Wrapper, you've been great. I've got colors rocking off multiple variables and outside borders reformatting for contractors. The only ask I'm not able to work through is some different borders for people with subordinates.
Looking at the properties of the cells, it LOOKS like I could key off of this one but the same code isn't picking up the cell.
User.HasSubordinates


Sub SubOrdinateTest()

    Dim pg As Page
    Dim sh As Shape
    Dim newColor As String

    For Each pg In ActiveDocument.Pages
        For Each sh In pg.Shapes
            'All Employees with Subordinates have double borders PENDING
                If sh.CellExists("User.HasSubordinates", visExistsAnywhere) Then
                     If sh.Cells("User.HasSubordinates").ResultStr(visNone) Like "1" Then
                        sh.CellsU("CompoundType").FormulaU = "1"
                        Call SubOrbDouble(sh.Shapes, newColor)
                    End If
                End If
             'All Employees with Subordinates have 2.25 thick borders PENDING
                If sh.CellExists("User.ShapeType", visExistsAnywhere) Then
                     If sh.Cells("User.ShapeType").ResultStr(visNone) = "1" Then
                        sh.CellsU("LineWeight").FormulaU = "=2.25 pt"
                        Call SubOrbThick(sh.Shapes, newColor)
                    End If
                End If
    Next
Next

End Sub



Sub SubOrbThick(shps As Visio.Shapes, nClr As String)
    ' Sets thicker outline on all subshapes to match
    Dim sh As Shape
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
                On Error Resume Next
                sh.Cells("LineWeight").Formula = "=2.25 pt"
        End If
        ConShapes sh.Shapes, nClr
    Next sh
End Sub


Sub SubOrbDouble(shps As Visio.Shapes, nClr As String)
    ' Sets double outline on all subshapes to match
    Dim sh As Shape
    For Each sh In shps
        If sh.Shapes.Count = 0 Then
                On Error Resume Next
                sh.Cells("CompountType").Formula = "1"
        End If
        ConShapes sh.Shapes, nClr
    Next sh
End Sub



While not as clean, User.ShapeType also could be an option since values of 0 and 1 have subordinates. I couldn't get that one to work either. Everything else is working great so I feel like there is something I'm missing. The design themes in Visio 2013 are picking up the differences and coloring the cells by that ShapeType... so it's there and I'm just missing it.

wapperdude

#28
Hey!

First, before starting, for the future could you place the code inside the code window?  See "#" icon above.

Second, I couldn't get too far, but did find these:

Change this line: If sh.Cells("User.HasSubordinates").ResultStr(visNone) Like "1" Then
to this line:  If sh.Cells("User.HasSubordinates").ResultStr(visNone) Then

I believe the only values are either 0 or 1, i.e., false or true.  At any rate, the "Like" test was failing for me.  Treating the User.HasSub as a Boolean seemed to work.

The other thing, I'm pretty sure that the following line has an invalid cell name:  sh.CellsU("CompoundType").FormulaU = "1" 
First, there is no prefix indicated.  Second, I couldn't find CompoundType.

That's as far as I've been able to go.

Wapperdude
Visio 2019 Pro