VBA to get shape info (Visio 2007 flowchart)

Question

All, I've been googling for answer to no avail. I'm pretty decent with VBA in Excel and Word but Visio is pretty new to me.

Background: someone (who's left company) created a very nice Visio process flowchart. Note: in our company we're restricted to Visio 2007. What I need to do is get a simple list of the text in each shape in the order the shapes occur in the process flow. (Also need shape colour info, for reasons that aren't worth going into.) I need this to present as a list in a non-Visio format (eg, slides).

So I first tried the code below, thinking I could use the index number for this--but turns out the flowchart author stuck in some shapes (boxes) out of order. So I thought maybe ordering in terms of X and Y coordinates would help--and it was better, except some boxes are a little higher on the Y axis than their predecessor/parent, so that didn't work.

I'm sure there's a better way for what must be a simple task, but for the life of me can't find it. I'm thinking it must be possible to do something like: starting with shape 1 (get shape text), this connects to shape 2 (get shape text), and so on... Can anyone point me in the right direction?

Thanks in advance

Sub list_shapes()
Dim sh As Shape
For Each sh In ThisDocument.Pages(2).Shapes
   Debug.Print n; "text= "; sh.Text; "shapename= "; sh.Name; "index= "; sh.Index; "shapetype= "; sh.Type; "x-coordinate="; sh.Cells("PinX"); "y-coordinate="; sh.Cells("PinY"); "[shapecolor="; sh.Cells("Fillforegnd")
Next
End Sub

AJD AJD · Accepted Answer · 2019-11-13T20:19:47

The good news is - since Visio 2010 there has been an easy way to do this, using the ConnectedShapes() method. The bad news is that you are limited to Visio 2007.

I will illustrate by example.

In the code below I have also included some older properties. Pre-2010, the method was to identify all the connectors and build a map by identifying the connected shapes and also identifying the presence (or absence) of arrows. Tedious but doable. Once you have set the code up, it can be re-used so the little amount of pain at the front in coding will help your reporting in the longer run.

The output is based on the following image on Page 1.

Private Sub ConnectionThings()

Dim testShape As Shape
Dim testPage As Page
    Set testPage = ThisDocument.Pages(1)

Dim testArray() As Long
Dim iterator As Long

    For Each testShape In testPage.Shapes
        If Not testShape.OneD Then
            testArray = testShape.ConnectedShapes(visConnectedShapesIncomingNodes, "")
            For iterator = LBound(testArray) To UBound(testArray)
                Debug.Print testShape.Text & " is connected to " & testPage.Shapes(testArray(iterator)).Text & " (incoming)."
            Next iterator
            testArray = testShape.ConnectedShapes(visConnectedShapesOutgoingNodes, "")
            For iterator = LBound(testArray) To UBound(testArray)
                Debug.Print testShape.Text & " is connected to " & testPage.Shapes(testArray(iterator)).Text & " (outgoing)."
            Next iterator
        End If
    Next testShape

        Debug.Print vbCrLf & "*** Demonstration of older properties *** "

    For Each testShape In testPage.Shapes
        Debug.Print testShape.Text & " is connected to " & testShape.Connects.Count & " shape(s)."
        Debug.Print testShape.Text & " is glued to " & " 1D shape(s): " & IsEmpty(testShape.GluedShapes(visGluedShapesAll1D, ""))
    Next testShape

Dim testConnectedShape As Shape
Dim testConnection As Connect
    For Each testShape In testPage.Shapes
        For Each testConnection In testShape.Connects
            Debug.Print testShape.Text & " is connected from " & testConnection.FromSheet.Text & " to " & testConnection.ToSheet.Text
        Next testConnection
    Next testShape
End Sub

R1 is connected to R2 (outgoing).

R2 is connected to R1 (incoming).

R2 is connected to R3 (outgoing).

R3 is connected to R2 (incoming).

* Demonstration of older properties *

R1 is connected to 0 shape(s).

R1 is glued to 1D shape(s): False

R2 is connected to 0 shape(s).

R2 is glued to 1D shape(s): False

R3 is connected to 0 shape(s).

R3 is glued to 1D shape(s): False

C1 is connected to 2 shape(s).

C1 is glued to 1D shape(s): False

C2 is connected to 2 shape(s).

C2 is glued to 1D shape(s): False

C1 is connected from C1 to R1

C1 is connected from C1 to R2

C2 is connected from C2 to R2

C2 is connected from C2 to R3

** Perhaps you could convince your company to allow Visio 2010 or later? After all, 2007 is over a decade old and out of support. Even 2010 is going out of support. My code was developed in Visio 2019 or 365 (not sure which, couldn't find the version number).

Addendum: Here is some older code that I used to follow the arrows. This was part of a larger body of code to create a full report, and I offer this here as an example of how to find the arrow head type. BPMNShape is a custom class as I was following a complex diagram - .BaseShape was the actual Visio shape in use. In your instance, you could simplify that to a simple 2-D shape or whatever master the key nodes are using. 'IsIntermediateandIsStart` merely confirm if the shapes are based on a particular master.

Private Function FindNextNonFlow2(ThePage As Page, TheShape As BPMNShape) As BPMNShape
' TheShape must be an intermediate or start
Dim t_Connect As Connect
Dim t_shape As New BPMNShape
Dim t_shape2 As New BPMNShape
Dim t_shape3 As New BPMNShape

    Set t_shape.BaseShape = TheShape.BaseShape
    If t_shape.IsSequence Then
        If t_shape.ArrowCodeEnd = 13 Then
            Set t_shape.BaseShape = ThePage.Shapes(t_shape.TriggerShapeEnd)
        Else
            Set t_shape.BaseShape = ThePage.Shapes(t_shape.TriggerShapeBegin)
        End If
    End If
    If t_shape.IsIntermediate Or t_shape.IsStart Then
        ' Code here
        ' use FromConnects
        ' End arrow = 13
        For Each t_Connect In t_shape.FromConnects
            Set t_shape2.BaseShape = t_Connect.FromSheet
            If t_shape2.IsSequence Then
                If t_shape2.ArrowCodeEnd = 13 And Not (ThePage.Shapes(t_shape2.TriggerShapeEnd) = t_shape.BaseShape) Then
                    Set t_shape3.BaseShape = ThePage.Shapes(t_shape2.TriggerShapeEnd)
                ElseIf t_shape2.ArrowCodeBegin = 13 And Not (ThePage.Shapes(t_shape2.TriggerShapeBegin) = t_shape.BaseShape) Then
                    Set t_shape3.BaseShape = ThePage.Shapes(t_shape2.TriggerShapeBegin)
                End If
            End If
        Next t_Connect
        If t_shape3.IsNotNothing Then Set t_shape = t_shape3
    End If
    Set FindNextNonFlow2 = t_shape
End Function

I had a "TO-DO" on the functions below (used in the above code): Add error checking and sensible fails.

Property Get ArrowCodeBegin() As Double
    ArrowCodeBegin = p_TheShape.CellsSRC(visSectionObject, visRowLine, visLineBeginArrow).Result(visNoCast)
End Property

Property Get ArrowCodeEnd() As Double
    ArrowCodeEnd = p_TheShape.CellsSRC(visSectionObject, visRowLine, visLineEndArrow).Result(visNoCast)
End Property

Property Get TriggerShapeEnd() As String
    TriggerShapeEnd = FindShapeName( _
                        p_TheShape.CellsSRC(visSectionObject, visRowMisc, visEndTrigger).Formula)
    'If p_TheShape Is Nothing Then Debug.Print "Issue: trid an operation on a null shape"
End Property

Property Get TriggerShapeBegin() As String
    TriggerShapeBegin = FindShapeName( _
                        p_TheShape.CellsSRC(visSectionObject, visRowMisc, visBegTrigger).Formula)
End Property

Private Function FindShapeName(TheTriggerString As String) As String
Dim t_string As String
    t_string = TheTriggerString
    If Len(t_string) > 0 Then
        t_string = Left(t_string, InStr(1, t_string, "!") - 1)
        t_string = Right(t_string, Len(t_string) - InStr(1, t_string, "("))
    End If
    t_string = Replace(t_string, "'", "")
    FindShapeName = Trim(t_string)
End Function

VBA to get shape info (Visio 2007 flowchart)

1 Answers