KP was also looking for code to order items using the label name instead of the index.
Personaly I don't think the code is the cleanest ever ( running true 30 properties, tsktsk )
Anyway, if people have any input, or can use it here's what we came up with.
The code below looks for six labels, and orders them. you can add more as you need.
You can do whatever you want to the items, hide them, order them, put in value's.
Public Sub ForAllShapes()
Dim UndoScopeID1 As Long
UndoScopeID1 = Application.BeginUndoScope("Order Fields")
Dim shp As Visio.Shape
Dim collShapes As Collection
Dim i As Integer, j As Integer, n As Integer
'// Get all shapes from the page
Set collShapes = New Collection
'// Shapes not considererd:
'// 1. Connectors
'// 2. Foreign objects (like Buttons)
'// 3. Guides
For Each shp In ActivePage.Shapes
If (shp.OneD = False) And _
(shp.Type <> Visio.VisShapeTypes.visTypeForeignObject) And _
(shp.Type <> Visio.VisShapeTypes.visTypeGuide) Then
Call collShapes.Add(shp)
End If
Next
'// Set the properties
'// Loop through ALL the shapes in the shapes collection:
For i = 1 To collShapes.Count
' Run through the first 30 properties looking for the right labels
' Check If the cell exists
' Then check if its the right description
' Then change the sortkey
' Exit when changed
' If none of the above do nothing and go to next property
' Changing Prop.Description
n = 0
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "Description" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "1"
Else
End If
Else
'If it does not exist
End If
Next n
'Changing Prop.Responsibility
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "Responsibility" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "2"
Else
End If
Else
'If it does not exist
End If
Next n
'' Prop.ACCOUNTABILITY
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "ACCOUNTABILITY" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "3"
Else
End If
Else
'If it does not exist
End If
Next n
'Change Prop.CONSULTED
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "CONSULTED" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "4"
Else
End If
Else
'If it does not exist
End If
Next n
'Change Prop.INFORMED
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "INFORMED" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "5"
Else
End If
Else
'If it does not exist
End If
Next n
'Change Prop.RISKID
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "RISKID" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "6"
Else
End If
Else
'If it does not exist
End If
Next n
'**************** copy the below*******************
'Change Prop.RiskRating1
For n = 0 To 30
If collShapes.Item(i).CellsSRCExists(visSectionProp, n, visCustPropsLabel, False) = -1 Then
If collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsValue).RowNameU = "RiskRating1" Then
collShapes.Item(i).CellsSRC(visSectionProp, n, visCustPropsSortKey).FormulaU = "7"
Else
End If
Else
'If it does not exist
End If
Next n
'*********************Up to here********************
'*********************And insert it here***************
'add more checks here
'*************************************************
'Next item in collection
Next i
'// Undo changes if not required
Application.EndUndoScope UndoScopeID1, True
Exit Sub
'// Prompt error if shape not found
Err:
MsgBox ("An error occoured, are you sure all selected shapes meet the requirements for the preformed action?")
'// Changes accepted
Application.EndUndoScope UndoScopeID1, False
End Sub
