How to display direct and indirect counts for Subordinates in Visio Organization

Joined
Jan 20, 2012
Messages
2
Reaction score
0
I have seen a large number of post related to this but unfortunately I could not find an easy answer to being able to display counts in org charts for Visio. As a result I coded (hacked may be a better term) the following macro for the desired functionality. Hopefully others will find it useful.

RecursiveCount - this is a recursive method that count subs uses and it does all the work.

CountSubs - This is the starting point. Select the top most node in your org chart then run this macro.

SetCountsToBlank - This is a little helper macro that resets all the org shapes on your diagram to "".

MakeBoxesBigger - This is another little helper macro that runs through and re-sizes your shapes. I have used this when I get long names etc. with moderate success. There may be better ways to do this with in the orgchart stuff.


HTML:
Function RecursiveCount(s As Shape) As String
    Dim count As Integer
    
    count = 0
    dc = s.FromConnects.count - 1
    
    For i = 1 To s.FromConnects.count
       If s.Text <> s.FromConnects(i).FromSheet.Connects(2).ToSheet.Text Then
            count = count + 1
            rc = RecursiveCount(s.FromConnects(i).FromSheet.Connects(2).ToSheet)
            count = count + rc
       End If
    Next
    If dc > 0 Then
        s.Shapes(4).Text = dc
        If (count > 0) And (count <> dc) Then
            s.Shapes(4).Text = s.Shapes(4).Text & "(" & count & ")"
        End If
    End If
    RecursiveCount = count
End Function
 
Sub CountSubs()
    ' select the top most node then run this macro
    Dim s As Shape
    Set s = ActiveWindow.Selection(1)
    
    ' now recursively update counts
    i = RecursiveCount(s)
    
End Sub
 
Sub SetCountsToBlank()
Dim s As Shape
For Each s In ActivePage.Shapes
        If s.Shapes.count >= 4 Then
            s.Shapes(3).Text = ""
            s.Shapes(4).Text = ""
    
        End If
    Next
End Sub
 
Sub MakeBoxesBigger()
Dim s As Shape
For Each s In ActivePage.Shapes
    If (s.Type = 2) Then
        s.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "1.37 in"
        s.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "0.6 in"
    End If
    Next
End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top