Assigning Shape Layers from a List in Visio

A Visio user recently asked if it is possible to assign shapes to layers from a list. In his case, he has an Excel table which he has exported shapes and their text using Visio’s Shape Reports feature, to which he has added a column named Layer, and he wants to assign the shapes to these layers. In this article, I demonstrate how this can be done.

I decided to use my MVP Session Wheel diagram ( see http://blog.bvisual.net/2012/06/29/mvp-sessions-wheel/ ) for this example because it already has some layers assigned.

I created a new Shape Report called Presenter Shapes, where I filtered all shapes on the current page to those where the Presenter Shape Data row exists, and the Presenter actually has a value:

I then chose to only export the <Shape ID> and Presenter columns, ordered by <Shape ID>:

I then ran the report to export into a new Excel Workbook:

I named the worksheet tab Shape Layers, and I deleted the first row with the PresenterShapes title in it, and added another column, named Layer, with the following formula:

=MID(RC[-1], FIND(” “,RC[-1])+1,LEN(RC[-1])-FIND(” “,RC[-1]))

This is just so that I could quickly name some layer for each row.

I saved the workbook then I then, in Visio, used the Link Data to Shapes feature to add this table as External Data.

Finally, I had everything in place to write some VBA code.

First I created two support functions that could tell me if a specified shape or layer exits on a specified page. (It would be so useful if similar functions were already in the Visio Type Library).

Private Function LayerExists(ByVal pag As Visio.Page, ByVal layerName As String) As Boolean

Dim lyr As Visio.Layer
Dim exists As Boolean

    For Each lyr In pag.Layers
        If LCase(lyr.Name) = LCase(layerName) Then
            exists = True
            Exit For
        End If
    Next
    
    LayerExists = exists
    
End Function

Private Function ShapeExists(ByVal pag As Visio.Page, ByVal id As Integer) As Boolean

Dim shp As Visio.Shape
Dim exists As Boolean

    For Each shp In pag.Shapes
        If shp.id = id Then
            exists = True
            Exit For
        End If
    Next
    
    ShapeExists = exists
    
End Function

Next I wrote the main sub routine, AssignLayers(),  which requires the selected recordset in the External Data window to have two particular columns, Shape ID and Layer. It uses the data in these columns to assign the shapes to the layer, but of course, it must add the layer to the page, if it doesn’t exist already.

Also, remember that Visio shapes can be assigned to zero, one or many layers, so the routine also asks whether you want to replace any existing layer assignments or just to add to them.

Public Sub AssignLayers()

Dim win As Visio.Window
Dim drs As Visio.DataRecordset

    For Each win In ActiveWindow.Windows
        If win.id = Visio.VisWinTypes.visWinIDExternalData Then
            Set drs = win.SelectedDataRecordset
            Exit For
        End If
    Next
    
    If drs Is Nothing Then
        MsgBox "There is no active DataRecordset", vbExclamation, "Assign Layers"
        Exit Sub
    End If

Dim iCol As Integer
Dim lyrColumn As Integer
Dim idColumn As Integer

    idColumn = -1
    lyrColumn = -1
    
    For iCol = 1 To drs.DataColumns.Count
        If drs.DataColumns.Item(iCol).Name = "Shape ID" Then
            idColumn = iCol - 1
        ElseIf drs.DataColumns.Item(iCol).Name = "Layer" Then
            lyrColumn = iCol - 1
        End If
    Next

    If idColumn = -1 Then
        MsgBox "There is no Shape ID column", vbExclamation, "Assign Layers"
        Exit Sub
    End If
    
    If lyrColumn = -1 Then
        MsgBox "There is no Layer column", vbExclamation, "Assign Layers"
        Exit Sub
    End If

Dim layerAction As Integer

    layerAction = MsgBox("Do you want to replace any existing layer assignments?" & _
        " (Select No to add the layer)", vbYesNoCancel, "Assign Layers")
    If layerAction = vbCancel Then
        Exit Sub
    End If

Dim rowIDs() As Long

    rowIDs = drs.GetDataRowIDs("")

Dim iRow As Integer
Dim data() As Variant
Dim lyrName As String
Dim shapeId As Integer
Dim shp As Visio.Shape
Dim lyr As Visio.Layer
Dim iLyr As Integer
Dim shapeOnLayer As Boolean

    For iRow = 0 To UBound(rowIDs)
        data = drs.GetRowData(rowIDs(iRow))
        shapeId = data(idColumn)
        lyrName = data(lyrColumn)
        If ShapeExists(ActivePage, shapeId) = True Then
            Set shp = ActivePage.Shapes.ItemFromID(shapeId)
            If LayerExists(ActivePage, lyrName) = False Then
                ActivePage.Layers.Add lyrName
            End If
            Set lyr = ActivePage.Layers.Item(lyrName)
            
            For iLyr = shp.LayerCount To 1 Step -1
                If LCase(shp.Layer(iLyr).Name) = LCase(lyrName) Then
                    shapeOnLayer = True
                Else
                    If layerAction = vbYes Then
                        ActivePage.Layers.Item(shp.Layer(iLyr).Name).Remove shp, 0
                    End If
                End If
            Next

            If shapeOnLayer = False Then
                lyr.Add shp, 0
            End If
        End If
    Next
    
End Sub

You may note that de-assigning and assigning shapes to layers in Visio is a little unintuitive because you have to get the page layer object and either remove or add the shape to it.

Also note that I have used zero as the second parameter to the layer.Add(…) and layer.Remove(…) methods. This ensures that the layer assignment is propagated to any sub-shapes.

The end result is that I can assign shapes to layers, and then I could switch off the visibility of Chris’s and Scott’s MVP sessions !

Of course, I wouldn’t recommend that you do switch their sessions off, because they are all gems !