Sample Code - Get the properties of the first shape selected and apply them to the other selected shapes
Sub setSamePropertyOfPrimaryShape()
Dim vsoSelection As Visio.Selection
Dim primaryShape As Visio.Shape 'first selected shape
Dim targetShape As Visio.Shape 'other selected shapes
Dim primaryShapePropsCount As Integer ' the number of properties of primaryShape
Dim PropArray() As Variant ' array to strage properties
Set vsoSelection = ActiveWindow.Selection 'current selection
Set primaryShape = vsoSelection.PrimaryItem 'set the first selected shape
primaryShapePropsCount = primaryShape.RowCount(Visio.visSectionProp)
With primaryShape
'Check if primaryShape has a property section
If .SectionExists(visSectionProp, 0) = False Then Exit Sub
ReDim PropArray(primaryShapePropsCount, 9)
For i = 0 To primaryShapePropsCount - 1
PropArray(i, 1) = .Section(visSectionProp).Row(i).NameU
PropArray(i, 2) = .CellsSRC(visSectionProp, i, visCustPropsLabel).FormulaU
PropArray(i, 3) = .CellsSRC(visSectionProp, i, visCustPropsType).FormulaU
PropArray(i, 4) = .CellsSRC(visSectionProp, i, visCustPropsFormat).FormulaU
PropArray(i, 5) = .CellsSRC(visSectionProp, i, visCustPropsLangID).FormulaU
PropArray(i, 6) = .CellsSRC(visSectionProp, i, visCustPropsCalendar).FormulaU
PropArray(i, 7) = .CellsSRC(visSectionProp, i, visCustPropsPrompt).FormulaU
PropArray(i, 8) = .CellsSRC(visSectionProp, i, visCustPropsValue).FormulaU
PropArray(i, 9) = .CellsSRC(visSectionProp, i, visCustPropsSortKey).FormulaU
Next
End With
For Each targetShape In vsoSelection
With targetShape
For i = 0 To primaryShapePropsCount - 1
'Check if the targetShape has a property that begins with Prop.
If .CellExists("Prop." & PropArray(i, 1), 0) = False Then
'If not, add a new row for the property
n = .AddRow(visSectionProp, visRowLast, visTagDefault)
End If
'Check if the name of the property is the same one as primaryShape
If .Section(visSectionProp).Row(i).NameU = PropArray(i, 1) Then
'Apply the properties of primaryShape to the target shape
.Section(visSectionProp).Row(i).NameU = PropArray(i, 1)
.CellsSRC(visSectionProp, i, visCustPropsLabel).FormulaU = PropArray(i, 2)
.CellsSRC(visSectionProp, i, visCustPropsType).FormulaU = PropArray(i, 3)
.CellsSRC(visSectionProp, i, visCustPropsFormat).FormulaU = PropArray(i, 4)
.CellsSRC(visSectionProp, i, visCustPropsLangID).FormulaU = PropArray(i, 5)
.CellsSRC(visSectionProp, i, visCustPropsCalendar).FormulaU = PropArray(i, 6)
.CellsSRC(visSectionProp, i, visCustPropsPrompt).FormulaU = PropArray(i, 7)
.CellsSRC(visSectionProp, i, visCustPropsValue).FormulaU = PropArray(i, 8)
.CellsSRC(visSectionProp, i, visCustPropsSortKey).FormulaU = PropArray(i, 9)
End If
Next
End With
Next
End Sub