Hi,
Please help me to solve my issue:
I have Visio 2010 standard and I want, using vba, color all the boxes that have one of the values set as "ITHH". Is there a code that I could use for that?
Thanks a lot!
Quote from: glaffitte on March 02, 2016, 05:54:39 PMIs there a code that I could use for that?
IMHO there haven't this code, someboby will write it especial for you!
Can you attach your example document there?
What I want to do is to color-code the boxes based on the value of the location. For example, I want all the boxes with Bangalore location to be brown.
I have attached an example.
Regards
Sub SomethingLikeAs()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.CellExists("Prop.Alocation", visExistsAnywhere) Then
If sh.Cells("Prop.Alocation").FormulaU = """Bangalore""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
End If
Next
End Sub
Thanks a lot!! I will test it today! ;D ;D ;D ;D
Hi again,
I tested today and works perfectly. What should I put instead of ActivePage so the macro applies the color coding to a visio document with multiple pages?
Thanks Again
try this
Sub SomethingElse()
Dim pg As Page
Dim sh As Shape
For Each pg In Activedocument.Pages
For Each sh In pg.Shapes
If sh.CellExists("Prop.Alocation", visExistsAnywhere) Then
If sh.Cells("Prop.Alocation").FormulaU = """Bangalore""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
End If
Next
Next
End Sub
This is exactly what I'm trying to do but the code from Surrogate isn't working for me in Visio Pro 2013. I even downloaded glaffite's original document and it's not running changing anything there. No errors.
How are you running the code?
View - Macros - Macros In - highlight Sub- Run
Open the vba window (alt + f11). Code s/b in this document, but you might have to hunt for it. Once you find the code, and it is displayed in the code window, the left mouse click in it, and then use f8 to step thru 1 line at a time. When you get to if statements, you can watch how each are executed. If the statements skip making any changes, then perhaps your file doesn't have the necessary info.
Using the Drawing2.vsd document attached above. (So my document wasn't even in play.)
It steps right from this line "If sh.CellExists("Prop.Allocation", visExistsAnywhere) Then" to "End If"
For Each sh In pg.Shapes
If sh.CellExists("Prop.Alocation", visExistsAnywhere) Then
If sh.Cells("Prop.Alocation").FormulaU = """Bangalore""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
End If
Is the If statement coming back a false so the "Then" portion never executes?
Looking at the statement, I don't see valid options for localeSpecificCellName.
CellExists( localeSpecificCellName , fExistsLocally )
https://msdn.microsoft.com/en-us/vba/visio-vba/articles/shape-cells-property-visio
Disclaimer: VERY new at this. Trying to teach myself a bit to solve an ongoing annoyance with Org charts... which would be usable for other diagrams.
Yes, the if statement is returning false, bypassing the then and going to end if.
I haven't looked at the file. The program is doing the following: It goes thru the file one page at at time. For each page, it goes thru each shape on that page. For each shape, it checks if the prop.alocation exists. If not, it goes to the next shape. If prop.alocation does exist, then it checks if it equals Bangalore. If it does, then it sets the color.
Prop.alocation may not exist in every shape on the page. When it does exist, its value may not equal Bangalore. Both conditions are necessary for the color to be assigned dark red. Note, if the color is already dark red, you won't notice any color change.
When you press f8, the program literally executes one statement at a time. When there are, say, 10 shapes on the page, the shape loop must execute 10 times, once for each shape. Similarly, if there's more than one page, the process must repeat for each page. Once everything has been processed, the code will finally execute end sub statement and be finished.
In the link you provided, the entry "localeSpecificCellName" is merely a syntax place holder. In use, an actual cell name goes in its place. In this example, prop.alocation, is the literal name. Well, technically, prop.alocation.value, but Visio knows that by default, and drops the .value.
HTH,
Wapperdude
Possibly a user error problem. I reviewed the logic and since it worked for others, closed and reset the Macro. It worked there.
Taking the logic and trying to mirror that to the project I'm working on... is the next step.
Trying to color the org chart where "Contractors" are one color and anyone working at "XYZ TV" is another color. I'm hitting the same issue here where it's skipping past the "If" statement as if it's not finding anything.
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.Alocation", visExistsAnywhere) Then
If sh.Cells("Prop.Alocation").FormulaU = """Contractor""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
End If
If sh.CellExists("Prop.Alocation", visExistsAnywhere) Then
If sh.Cells("Prop.Alocation").FormulaU = """XYZ TV""" Then sh.Cells("Fillforegnd").Formula = visDarkRed
End If
Next
Next
End Sub
Your shapes have a shape data entry Prop.Alocation?
You'll need to save as vsd for me to look at the file.
Wapperdude
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.
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.)
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
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
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.)
BTW, vsdx format not readable by V2007. Need plan ol' vsd.
VSD file only. Same results.
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
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.
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
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
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.)
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.
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