Do Amazing things in Visio

visio.vba

Public Sub addConnectionPointToShapeH()
    Dim var As Integer
        var = CInt(InputBox(Prompt:="Please enter the number of rows or subdivisions for the shape.", _
                        Title:="User Information", _
                        Default:=5))
    Call addConnectionPointsShape(var, True)
End Sub
Public Sub addConnectionPointToShapeV()
    Dim var As Integer
            var = CInt(InputBox(Prompt:="Please enter the number of rows or subdivisions for the shape.", _
                            Title:="User Information", _
                            Default:=5))
    Call addConnectionPointsShape(var, False)
End Sub
Public Sub addConnectionPointsCustom()
    Dim var As Integer
    var = CInt(InputBox(Prompt:="Please enter the number of rows or subdivisions for the shape.", _
                    Title:="User Information", _
                    Default:=5))

    Call addConnectionPointsShape(var, False)
    Call addConnectionPointsShape(var, True)
End Sub
Public Sub addFiveConnectionPoints()
    Dim var As Integer
        var = 5
    Call addConnectionPointsShape(var, False)
    Call addConnectionPointsShape(var, True)
End Sub


Public Sub addConnectionPointsShape(Optional connectionPoints As Integer, Optional bHorizontal As Boolean)

Dim selectedShapes As Selection
Dim theShape As shape
Dim index As Integer, i As Integer, j As Integer
Dim rowNumber As Integer
Dim UPPER As Integer
Dim var As Variant

If IsMissing(bHorizontal) Then
    bHorizontal = False
End If

var = connectionPoints

If var <> vbCancel Then
    UPPER = var
Else
    Exit Sub
End If

Set selectedShapes = ActiveWindow.Selection

For index = 1 To selectedShapes.Count
    Set theShape = selectedShapes.Item(index)
    If theShape.SectionExists(Visio.visSectionConnectionPts, 1) = False Then
        theShape.AddSection (Visio.visSectionConnectionPts)
    End If
    For i = 1 To UPPER
        For j = 1 To 2
            rowNumber = theShape.AddRow(Section:=Visio.visSectionConnectionPts, _
                    Row:=Visio.visRowConnectionPts, _
                    RowTag:=Visio.VisRowTags.visTagCnnctPt)
            Select Case j
                Case 1:
                If Not bHorizontal Then
                    theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                    Row:=Visio.visRowConnectionPts, _
                                    Column:=Visio.visX).Formula = "=width*0"
                    theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                    Row:=Visio.visRowConnectionPts, _
                                    Column:=Visio.visY).Formula = "=" & i & "*(height/" & UPPER & ") - Height/" & 2 * UPPER
                Else
                    theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                    Row:=Visio.visRowConnectionPts, _
                                    Column:=Visio.visY).Formula = "=height*0"
                    theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                    Row:=Visio.visRowConnectionPts, _
                                    Column:=Visio.visX).Formula = "=" & i & "*(width/" & UPPER & ") - width/" & 2 * UPPER
                End If
                Case 2:
                    If Not bHorizontal Then
                        theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                        Row:=Visio.visRowConnectionPts, _
                                        Column:=Visio.visX).Formula = "=width*1"
                        theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                        Row:=Visio.visRowConnectionPts, _
                                        Column:=Visio.visY).Formula = "=" & i & "*(height/" & UPPER & ") - Height/" & 2 * UPPER
                    Else
                        theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                        Row:=Visio.visRowConnectionPts, _
                                        Column:=Visio.visY).Formula = "=height*1"
                        theShape.CellsSRC(Section:=Visio.visSectionConnectionPts, _
                                        Row:=Visio.visRowConnectionPts, _
                                        Column:=Visio.visX).Formula = "=" & i & "*(width/" & UPPER & ") - width/" & 2 * UPPER
                    End If
            End Select
        Next j
    Next i
Next index
End Sub

Public Sub SetMasterShape()
    Dim var As String
    Dim index As Integer, shapeID As Integer
    Dim selectedShapes As Selection
    Dim workingShape As shape, masterShape As shape
    Dim masterName As String

    ' Get shape ID
    var = InputBox(Prompt:="Please enter the shape ID of master shape.", _
               Title:="Master Shape Query", _
               Default:="")

    ' Check if user cancelled or shape doesn't exist
    If var <> "" Then
        shapeID = CInt(var)
        If CheckShapeExists(shapeID) <> True Then
            MsgBox "Shape ID " & shapeID & " could not be found"
        End If
    Else
        Exit Sub
    End If

    ' Get name of masterShape
    Set masterShape = ActivePage.Shapes.ItemFromID(shapeID)
    masterName = masterShape.Name

    Set selectedShapes = ActiveWindow.Selection

    For index = 1 To selectedShapes.Count
        Set workingShape = selectedShapes.Item(index)

        workingShape.Cells("Width").FormulaForce = "GUARD(" & masterName & "!Width)"
        workingShape.Cells("Height").FormulaForce = "GUARD(" & masterName & "!Height)"
    Next index

End Sub



Function CheckShapeExists(shapeID As Integer) As Boolean
    ' Checks if shape with given ID exists
    Dim shape As Visio.shape

    On Error Resume Next
    Set shape = ActivePage.Shapes.ItemFromID(shapeID)
    On Error GoTo 0

    CheckShapeExists = shapeFound

    If Not shape Is Nothing Then
        CheckShapeExists = True
    Else
        CheckShapeExists = False
    End If
End Function