Macro with ReplaceShape & change colour and size based on IF statement condition

[Simone]

Hello, I searched alot for answers on this and there isn't much about combining IF conditions with ReplaceShape as well as changing shape properties in the shape sheet.  Basically, I need to write a macro to change shapes and their colours and sizes based a property in the shape sheet.  This macro is to be run after the user has populated the visio diagram with shapes including connectors.  The property in the shape sheet is only on shapes from the initial stencil not on connectors or containers.  Reason for this need is that the editing time on one active page can take hundreds of hours for the user to do, and based on formating requirements it would be efficient to have this automated with use of a macro.

I've written a macro with one IF condition based on a value of a property in the shape sheet. So, if the shape has that property set as specified then the shape is to be replaced by a different shape from the Basic Shapes and the fill colour is to be changed as well as the width and height.  There will be other shapes with a different value for the vsoShape.CellsSRC(visSectionProp, 4, visCustPropsValue).Formula in the IF condition that will require different fill colours applied.  However, I am just starting with one IF statement.

When I run this macro, I just get the message box presented and nothing happens to any of the shapes. No error either.  Here is the code used below.
From recording a macro, I believe I have the CellsSRC details correct.
Help would be appreciated, thanks so much. 

Code Select Expand


Sub ChangeShapeandColour()
'changes shape, colour and size based a shape property in shape sheet

Dim sh As Shape
Dim objshape As Visio.Shape
Dim vsoShapes As Visio.Shapes
Dim vsoShape As Visio.Shape
Set vsoShapes = ActivePage.Shapes
For Each vsoShape In vsoShapes


If vsoShape.CellsSRC(visSectionProp, 4, visCustPropsValue).Formula = "Initiative" Then
Set sh = vsoShape.ReplaceShape(Application.Documents.Item("BASIC_M.vssx").Masters.ItemU("Circle"))
   
sh.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaForceU = "THEMEGUARD(RGB(152,232,243))"
sh.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaForceU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEMEVAL(""FillColor""),THEMEVAL(""FillColor2""))))"
sh.CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaForceU = "FALSE"
sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaForceU = "30.0"
sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaForceU = "30.0"
End If

Next

MsgBox "Script is Complete"
End Sub



[Simone]

I actually find the solution to my issue.  It required the ch(34) use.  Now, I have built out the macro code further and it works perfectly.  If this topic should be removed, I don't mind.
But, if other people will find the code helpful here it is:

Code Select Expand

Sub ChangeShapeandColour()
'changes shape, colour and size based a shape property in shape sheet

Dim sh As Shape
Dim objshape As Visio.Shape
Dim vsoShapes As Visio.Shapes
Dim vsoShape As Visio.Shape
Set vsoShapes = ActivePage.Shapes
For Each vsoShape In vsoShapes
Debug.Print vsoShape.ID

    If vsoShape.CellsSRC(visSectionProp, 4, visCustPropsValue).Formula = Chr(34) & "Initiative" & Chr(34) Then
        Set sh = vsoShape.ReplaceShape(Application.Documents.Item("BASIC_M.vssx").Masters.ItemU("Circle"))
        Debug.Print sh.ID
        Debug.Print sh.Name
        sh.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaForceU = "THEMEGUARD(RGB(38,87,153))"
        sh.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaForceU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEMEVAL(""FillColor""),THEMEVAL(""FillColor2""))))"
        sh.CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaForceU = "FALSE"
        sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaForceU = Chr(34) & "30 mm" & Chr(34)
        sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaForceU = Chr(34) & "30 mm" & Chr(34)
        CellsSRC(visSectionCharacter, 0, visCharacterColor).FormulaU = "THEMEGUARD(RGB(255,255,255))"
       
    ElseIf vsoShape.CellsSRC(visSectionProp, 4, visCustPropsValue).Formula = Chr(34) & "Project" & Chr(34) Then
        Set sh = vsoShape.ReplaceShape(Application.Documents.Item("BASIC_M.vssx").Masters.ItemU("Circle"))
        Debug.Print sh.ID
        Debug.Print sh.Name
        sh.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaForceU = "THEMEGUARD(RGB(204,255,153))"
        sh.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaForceU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEMEVAL(""FillColor""),THEMEVAL(""FillColor2""))))"
        sh.CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaForceU = "FALSE"
        sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaForceU = Chr(34) & "30 mm" & Chr(34)
        sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaForceU = Chr(34) & "30 mm" & Chr(34)
   
    ElseIf vsoShape.CellsSRC(visSectionProp, 4, visCustPropsValue).Formula = Chr(34) & "Program" & Chr(34) Then
        Set sh = vsoShape.ReplaceShape(Application.Documents.Item("BASIC_M.vssx").Masters.ItemU("Circle"))
        Debug.Print sh.ID
        Debug.Print sh.Name
        sh.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaForceU = "THEMEGUARD(RGB(152,232,243))"
        sh.CellsSRC(visSectionObject, visRowFill, visFillBkgnd).FormulaForceU = "THEMEGUARD(SHADE(FillForegnd,LUMDIFF(THEMEVAL(""FillColor""),THEMEVAL(""FillColor2""))))"
        sh.CellsSRC(visSectionObject, visRowGradientProperties, visFillGradientEnabled).FormulaForceU = "FALSE"
        sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaForceU = Chr(34) & "30 mm" & Chr(34)
        sh.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaForceU = Chr(34) & "30 mm" & Chr(34)
    Else
       
    End If

Next

MsgBox "Script is Complete"
End Sub


[Visio Guy]

If you are setting values (instead of formulas) you can also set the result for a cell. This can be typed with units.

Visio uses inches as its internal units, so you can set a value like this:

Code Select Expand

shp.Cells("Width").ResultIUForce = 2.5

For metric, you can do this:

Code Select Expand

shp.CellsU("Width").ResultForce(Visio.VisUnitCodes.visMillimeters)

Note how I accessed the cells by Cells and CellsU. You can get at cells by name, instead of the whole section, row, column thing, although the indices are probably faster.


You can also get section and row objects to save some code/typing:

Code Select Expand


  '// Get the first selected shape:
  Dim shp As Visio.Shape
  Set shp = Visio.ActiveWindow.Selection(1)
 
  '// Get a row:
  Dim row As Visio.row
  Set row = shp.Section(visSectionObject).row(visRowFill)
 
  row(Visio.VisCellIndices.visFillForegnd).FormulaForceU = "RGB(0,255,0)
  row(Visio.VisCellIndices.visFillBkgnd).FormulaForceU = "RGB(0,255,0)"
  row(Visio.VisCellIndices.visFillForegndTrans).ResultIUForce = 0.5


[Simone]

Yes, setting values for the Width and height is exactly what I am trying to do as you picked up.   Ah, I didn't know Visio uses inches as it's internal metric - I was about to go our friend Google for that. Everything you say makes sense. I wasn't sure on use of setting of result.  I've done alot of SQL coding but my VBA is going through a good learning curve to improve.

Thanks again for your recommendations on how to save some code and use better code for the actions I am trying to acheive!  I will apply this as I have to write another macro very similar.

Also, your site was recommended to me and I find it very useful!  Thanks again for replying to me!  Certainly worthwhile to have you look at my code.