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 https://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 !