Sub ConnPts()
' This macro explores adding connection points to a shape programmitically.
' It is not necessary to add the Connection Point section prior to adding rows.
' This code presumes there are no pre-existing connection points.
' Using visTagCnnctPt seems to cause grief.
Dim vsoShp As Visio.Shape
Dim iRow As Integer
Dim vsoRow As Visio.Row
iRow = 0
For Each vsoShp In ActivePage.Shapes
vsoShp.AddRow visSectionConnectionPts, iRow, visTagCnnctPt
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(iRow)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*0"
.Cell(visCnnctY).FormulaU = "Height*0.5"
End With
vsoShp.AddNamedRow visSectionConnectionPts, "P" & iRow + 1, visTagCnnctNamed
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(iRow + 1)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*1"
.Cell(visCnnctY).FormulaU = "Height*0.5"
End With
' vsoShp.AddRow visSectionConnectionPts, iRow + 2, visTagCnnctPt
vsoShp.AddRow visSectionConnectionPts, iRow + 2, 0
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(iRow + 2)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*0.5"
.Cell(visCnnctY).FormulaU = "Height*1"
End With
Next
End Sub
Sub Nik()
ActivePage.Shapes(1).AddRow visSectionConnectionPts, 0, visTagCnnctPt
' ActivePage.Shapes(1).AddNamedRow visSectionConnectionPts, "P0", visTagCnnctNamed
End Sub
visTagCnnctPt, visTagCnnctNamed,
File visTagCnnctPtABCD visTagCnnctNamedABCD
-------------------------------------------------
CP1.vsd YES NO
CP2.vsd NO YES
ActivePage.Shapes(1).AddRow visSectionConnectionPts, 0, visTagCnnctPt
then hit enter.QuotevsoShp.AddRow visSectionConnectionPts, iRow, 0
vsoShp.DeleteRow visSectionConnectionPts, iRow
vsoShp.AddNamedRow visSectionConnectionPts, "P" & iRow, visTagCnnctNamedABCD
ActivePage.Shapes(1).AddRow visSectionConnectionPts, 0, visTagCnnctPt
Sub ConnPts()
Dim vsoShp As Visio.Shape
Dim iRow As Integer
iRow = 0
Set vsoShp = ActiveWindow.Selection(1)
vsoShp.AddRow visSectionConnectionPts, iRow, 0
vsoShp.DeleteRow visSectionConnectionPts, iRow
vsoShp.AddNamedRow visSectionConnectionPts, "P" & iRow, visTagCnnctNamedABCD 'Row index starts at "0", but want names to start at "1"
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(iRow)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*0"
.Cell(visCnnctY).FormulaU = "Height*0.5"
End With
vsoShp.AddNamedRow visSectionConnectionPts, "P" & iRow + 1, visTagCnnctNamedABCD 'Row index starts at "0", but want names to start at "1"
vsoShp.DeleteRow visSectionConnectionPts, iRow + 1
vsoShp.AddRow visSectionConnectionPts, iRow + 1, 0
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(iRow + 1)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*1"
.Cell(visCnnctY).FormulaU = "Height*0.5"
End With
vsoShp.AddRow visSectionConnectionPts, iRow + 2, 0
Set vsoRow = vsoShp.Section(visSectionConnectionPts).Row(iRow + 2)
With vsoRow
.Cell(visCnnctX).FormulaU = "Width*0.5"
.Cell(visCnnctY).FormulaU = "Height*1"
End With
End Sub