Create Visio Horizontal Swimlane from Excel ActiveSheet

pbornemeier

Well-known Member
I was working on another Visio-automation-related question in the forum and a participant asked about adapting it for swimlanes. There are a few rough spots in this code, but it does work. Feedback/suggestions would be appreciated.

Code:
'Create a worksheet with the following characteristics

' A = Process Number    Unique integer to identify each Shape (Phases do not get a process number)
'                         Ascending sequence recommended, not required
' B = Shape Type:       Phase, Process, Decision, Start/End, Document, Data, <blank>
'                         
' C = Offset from Prev  0 Forces block to aligned vertically with previous block
'                       Any number (+/-) offsets the next block from the previous block by that amount
'                       An empty cell uses the default offset (1.5 inches)
' D = Shape Text        Text in the shape (Phase text at top right corner of Phase Block)
'                       Font defaults to 18 point and will be reduced as far as 8 point to 
'                         fit it into the shape
' E = Lane ID		Party Responsible for Task
' F = Connector Text    Text in the connector
' G = Successor Index   Process number for connector destination (Phases do not get a Successor Index)
' H = leave blank          Will be filled with ShapeID

'If you want the lanes to appear in a particular order, populate column D of the 
'  first data rows of the worksheet with the Responsible Party identifiers

'Every shape except Phase and <blank> (and the ending Start/End) must have a Lane ID and a Successor Index

Excel Workbook
ABCDEFG
1ProcessNumberShape TypeOffset from PreviousShape TextLane IDConnector TextSuccessorIndex
2****1st Level Support**
3****Advanced Support**
4****Engineering**
51Start/End*Receive Complaint1st Level Support*2
62Process*Log Complaint1st Level Support*3
73Process*Review problem DB1st Level Support*4
84Decision*Known Problem ?1st Level SupportYes5
9*****No7
105Process*Inform Customer of Fix1st Level Support*6
116Start/End*Close Out Log1st Level Support**
127Process-6Investigate ProblemAdvanced Support*8
138Decision*Workaround Found?Advanced SupportYes9
14*****No11
159Process*Update Problem DBAdvanced Support*10
1610Process*Inform Customer of WorkaroundAdvanced Support*6
1711Process-6Investigate SeverityEngineering*12
1812Decision*Severity ?EngineeringSevere13
19*****Routine14
2013Process*Add Critical Patch RequestEngineering*15
2114Process*Add Change Request for Next ReleaseEngineering*15
2215Process*Update Problem DBEngineering*16
2316Process*Inform Customer of StatusEngineering*6
Sheet3


Code:
Option Explicit
Dim AppVisio As Object

Sub CreateHorizontalSwimLanesFromExcelData()
    'Given a properly constructed worksheet, create a cross-functional flow diagram
    
    Dim aryRange() As Variant '(1,1)...(1,N)   'Process Number,  Shape Type,  Shape Text,  Lane ID, Connector Text,  Successor Index

    Dim aryContents() As Variant    '0...N
    Dim lAryRangeIndex As Long
    Dim bAllInSameVisio As Boolean
    Dim varLaneData() As Variant
    Dim lVarLaneData As Long
    
    Dim lLastDataRow As Long
    Dim sLaneName As String
    Dim varI As Variant
    Dim varK As Variant
    Dim lX As Long
    Dim lLaneCount As Long
    
    Dim lProcNum As Long
    Dim sShapeType As String
    Dim varAlign As Variant
    Dim sShapeText As String
    Dim varLane As Variant
    Dim sConnText As String
    Dim lSuccIndex As Long
    Dim varPreviousLane As Variant
    
    Dim bSkipRow As Boolean
    Dim sngXPos As Single
    Dim sngSameRowDeltaX As Single
    Dim sngDiffRowDeltaX As Single
    Dim sngDeltaX As Single
    Dim bSameRow As Boolean
    
    Dim lFromIndex As Long
    Dim lToIndex As Long
    Dim lFromShape As Long
    Dim lToShape As Long
    Dim lShapeID As Long
    
    Dim sngRightEdgePos As Single
    
    bAllInSameVisio = True
    
    sngXPos = 0.5
    sngSameRowDeltaX = 1.5
    sngDiffRowDeltaX = 1.5
    
    'Load Definition Array from activesheet
    ' A = Process Number    Unique number to identify each Shape (Phases do not get a process number)
    ' B = Shape Type:       <blank>, Phase, Process, Decision, Start/End, Document, Data
    ' C = Offset from Prev  Forces block to aligned vertically with previous block
    ' D = Shape Text        Text in the shape (Phase text at top right corner of Phase Block)
    ' E = Lane ID
    ' F = Connector Text    Text in the connector
    ' G = Successor Index   Process number for connector destination (Phases do not get a Successor Index)
    ' H = <empty>           Will be filled with ShapeID
    
    lLastDataRow = Range("A1").CurrentRegion.Rows.Count
    aryRange = ActiveSheet.Range("A1:H" & lLastDataRow).Value

    'Get Lanes From Loaded Data ('Uniques in column D)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        
        'Inventory column E, row 1 to last populated cell in column E
        For lAryRangeIndex = LBound(aryRange) To UBound(aryRange)
            sLaneName = aryRange(lAryRangeIndex, 5)
            If sLaneName <> vbNullString And sLaneName <> "Lane ID" Then
                .Item(sLaneName) = .Item(sLaneName) + 1
            End If
        Next
        
        'Copy Values (Keys) and Counts (Items) to 1D arrays
        varK = .Keys
        varI = .Items
        
        'Copy both to 2D array
        ReDim varLaneData(1 To 2, 1 To .Count)
        For lX = 1 To .Count
            varLaneData(1, lX) = varK(lX - 1)
            varLaneData(2, lX) = varI(lX - 1)
        Next
    End With
    
    If bAllInSameVisio Then
        'Is Visio already running
        On Error Resume Next
        ' Check whether Visio is running
        Set AppVisio = GetObject(, "Visio.Application")
        If AppVisio Is Nothing Then
            ' Visio is not running, create new instance
            Set AppVisio = CreateObject("visio.Application")
            AppVisio.Visible = True
        End If
    Else
        'Open new copy of Visio
        Set AppVisio = CreateObject("visio.Application")
        AppVisio.Visible = True
    End If
    On Error GoTo 0
    
    'Add New Drawing
    AppVisio.Documents.AddEx "xfunc_u.vst", 0, 0 'visMSDefault, 0
    
    lLaneCount = UBound(varLaneData, 2)
    Select Case lLaneCount
    Case 0
        Stop
        'Error or default to 1 lane ??
    Case 1
        'Delete 1 lane
        ActiveWindow.DeselectAll
        ActiveWindow.Select Application.ActiveWindow.Page.Shapes.ItemFromID(6), 2   '2 = visSelect
        Application.ActiveWindow.Selection.Cut
    Case 2
        'Do nothing, 2 lanes present by default
    Case Else
        For lX = 3 To lLaneCount
            AppVisio.ActivePage.DropIntoList _
                AppVisio.Documents.Item(1).Masters.ItemU("Swimlane"), _
                AppVisio.ActivePage.Shapes.ItemFromID(4), 3
        Next
    End Select
    
    
    varLaneData = ReturnSwimlanesInfo(varK)     '(1,1)...(4,x)  Shape, YPos, Name,  Shape ID
    
    For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
        'Update varLane
        For lVarLaneData = LBound(varLaneData, 2) To UBound(varLaneData, 2)
            If aryRange(lAryRangeIndex, 5) = varLaneData(3, lVarLaneData) Then
                 aryRange(lAryRangeIndex, 5) = varLaneData(2, lVarLaneData)
                Exit For
            End If
        Next
    Next
    
    For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
        'Evaluate each data row
        
        bSkipRow = False
        
        lProcNum = aryRange(lAryRangeIndex, 1)
        sShapeType = Trim(aryRange(lAryRangeIndex, 2))
        varAlign = aryRange(lAryRangeIndex, 3)
        sShapeText = Trim(aryRange(lAryRangeIndex, 4))
        varLane = aryRange(lAryRangeIndex, 5)
        sConnText = Trim(aryRange(lAryRangeIndex, 6))
        lSuccIndex = aryRange(lAryRangeIndex, 7)
        
        'Debug.Print lAryRangeIndex & "  " & lProcNum & "  " & sShapeType & "  " & _
            varAlign & "  " & sShapeText & "  " & varLane & "  " & sConnText & "  " & lSuccIndex

        If lProcNum = 0 And sShapeType = vbNullString Then bSkipRow = True

        If Not bSkipRow Then
        
            'Calculate New Horizontal Offset
            If sShapeType = "Phase" Or sShapeType = vbNullString Then
                sngDeltaX = 0
            Else
                Select Case varAlign
                Case vbNullString
                    'No entry, use default spacing
                    If varLane = varPreviousLane Then
                        bSameRow = True
                        sngDeltaX = sngSameRowDeltaX
                    Else
                        bSameRow = False
                        sngDeltaX = sngDiffRowDeltaX
                    End If
                Case Is = 0
                    'Align with last plotted shape
                    sngDeltaX = 0
                Case Is > 0, Is < 0
                    'Use entered manual offset
                    sngDeltaX = varAlign
                Case Else
                    'Bad entry, use default spacing
                    If varLane = varPreviousLane Then
                        bSameRow = True
                        sngDeltaX = sngSameRowDeltaX
                    Else
                        bSameRow = False
                        sngDeltaX = sngDiffRowDeltaX
                    End If
                End Select
            End If
            sngXPos = sngXPos + sngDeltaX
            
            
            Select Case sShapeType
            Case "Phase"
                sngRightEdgePos = Replace(AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(1, 1, 2).FormulaU, " in", "")
                If sngRightEdgePos < sngXPos + 1.5 Then
                    MsgBox "I have not found a way to programatically adjust the swim lane width." & vbLf & vbLf & _
                        "1) Click OK" & vbLf & _
                        "2) Switch to Visio window" & vbLf & _
                        "3) Adjust the swim lane to as wide as you think you will need" & vbLf & _
                        "4) Return to this screen and press F5", , "Widen Swimlane manually"
                    Stop
                    'SetSwimLaneWidth sngXPos + 1.5 'Would be nice if this worked
                End If
                
                AddPhaseSeparator sngXPos + 0.625, sShapeText
            Case "Process", "Decision", "Subprocess", "Start/End", "Document", "Data"
                aryRange(lAryRangeIndex, 8) = Drop1Shape(lProcNum, sShapeType, sShapeText, sngXPos, CSng(varLane))
                varPreviousLane = varLane
            Case Else
                'Invalid Shape Type - do nothing
            End Select
            
        End If
    Next
    
    SetSwimLaneWidth sngXPos + 1
    
    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        
        'Inventory aryRange to to get shape number for each process #
        For lAryRangeIndex = LBound(aryRange) To UBound(aryRange)
            If IsNumeric(aryRange(lAryRangeIndex, 1)) And aryRange(lAryRangeIndex, 1) <> 0 Then
                .Item(aryRange(lAryRangeIndex, 1)) = aryRange(lAryRangeIndex, 8)
            End If
        Next
        
        'Copy Values (Keys) and Counts (Items) to 1D arrays
        varK = .Keys
        varI = .Items
        
        'Copy both to 2D array
        ReDim aryProcToShape(1 To 2, 1 To .Count)
        For lX = 1 To .Count
            aryProcToShape(1, lX) = varK(lX - 1)
            aryProcToShape(2, lX) = varI(lX - 1)
        Next
    End With
    

    'Connect Shapes
    For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
    
        If aryRange(lAryRangeIndex, 7) <> 0 Then    'Successor Present
            lToIndex = aryRange(lAryRangeIndex, 7)
            If aryRange(lAryRangeIndex, 1) <> 0 Then
                lFromIndex = aryRange(lAryRangeIndex, 1)
            End If
            
            
            For lX = LBound(aryProcToShape, 2) To UBound(aryProcToShape, 2)
                If lFromIndex = aryProcToShape(1, lX) Then lFromShape = aryProcToShape(2, lX)
                If lToIndex = aryProcToShape(1, lX) Then lToShape = aryProcToShape(2, lX)
            Next
            
            'Debug.Print lFromIndex, lToIndex, lFromShape, lToShape
            lShapeID = DoAutoConnect(lFromShape, lToShape, CStr(aryRange(lAryRangeIndex, 6)))
            aryRange(lAryRangeIndex, 8) = lShapeID
        End If
    Next
    
    Set AppVisio = Nothing
    'Set vsoCharacters = Nothing
End Sub

Function ReturnUniquesAndCountsInSelectedRanges(rngInput As Range)
    'Return selected cells' unique values and counts
    
    Dim lX As Long, lY As Long
    Dim rngSelected() As Range  'Array that contains each selected cell
    Dim lSelectedCount As Long
    Dim varA As Variant
    Dim varOutput As Variant
    Dim varK As Variant, varI As Variant
    
    'Iterate all areas; each individual cell into 1D array
    For lX = 1 To rngInput.Areas.Count
        For lY = 1 To rngInput.Areas(lX).Cells.Count
            If Len(rngInput.Areas(lX).Cells(lY).Value) <> 0 Then
                lSelectedCount = lSelectedCount + 1
                ReDim Preserve rngSelected(1 To lSelectedCount)
                Set rngSelected(lSelectedCount) = rngInput.Areas(lX).Cells(lY)
            End If
        Next
    Next
    
    With CreateObject("Scripting.Dictionary")
    
        .CompareMode = vbTextCompare
        
        'Inventory selected cells
        For Each varA In rngSelected
            .Item(varA.Value) = .Item(varA.Value) + 1
        Next
        
        'Copy Values (Keys) and Counts (Items) to 1D arrays
        varK = .Keys
        varI = .Items
        
        'Copy both to 2D array
        ReDim varOutput(1 To 2, 1 To .Count)
        For lX = 1 To .Count
            varOutput(1, lX) = varK(lX - 1)
            varOutput(2, lX) = varI(lX - 1)
        Next
        
    End With
    
    ReturnUniquesAndCountsInSelectedRanges = varOutput

    'Set rngInput = Nothing 'if this is uncommented then the range in the calling routine is set to Nothing as well

End Function

Function Drop1Shape(lProcessNumber As Long, sType As String, sText As String, _
    sngXPos As Single, sngYPos As Single) As Long
    'Adds a shape to the activesheet, returns the ID of the shape
    
    Dim lShapeID As Long

    AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("BASFLO_U.VSS"). _
        Masters.ItemU(sType), sngXPos, sngYPos
    lShapeID = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 2). _
        FormulaU = "1" 'visSectionObject, visRowXFormOut, visXFormWidth)
    If sType = "Start/End" Then
        AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 3). _
            FormulaU = "0.375" 'visSectionObject, visRowXFormOut, visXFormHeight)
    Else
        AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 1, 3). _
            FormulaU = "0.75" 'visSectionObject, visRowXFormOut, visXFormHeight)
    End If
    
    SetShapeText lShapeID, sText
    Drop1Shape = lShapeID
    
End Function

Sub SetShapeText(lShapeID As Long, sEntry As String)
    'Add Text to Shape, reduce font size from the default size if the text is taller that the shape
    
    Dim vsoCharacters1 As Object
    Dim sShapename As String
    Dim sngTextHeight As Single
    Dim sngFontDefaultSize As Single
    Dim vShapeheight As Variant
    Dim sngFontMinimumSize As Long
    
    sngFontDefaultSize = 18     'Initial size of font in points
    sngFontMinimumSize = 8      'Minimum size of font in points
    
    Set vsoCharacters1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Characters
    vsoCharacters1.Begin = 0
    vsoCharacters1.End = 0
    vsoCharacters1.Text = sEntry
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7).FormulaU = _
        sngFontDefaultSize & " pt"    'visSectionCharacter, 0, visCharacterSize
    
    vShapeheight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID). _
        CellsSRC(1, 1, 3).FormulaU  'visSectionObject, visRowXFormOut, visXFormHeight
    vShapeheight = Replace(vShapeheight, " in", "")
    
    'Debug.Print AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Name
    
    'Reduce vShapeheight for decision shapes
    If InStr(AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Name, "Decision") > 0 Then vShapeheight = vShapeheight / 2
    
    'Add a user-defined cell that contains the height of the textbox
    AppVisio.ActiveWindow.Shape.AddRow 242, 0, 0 'visSectionUser, 0, visTagDefault
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(242, 3, 0). _
        RowNameU = "TextHeight" 'visSectionUser, 3, visUserValue
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(242, 3, 0). _
        FormulaU = "TEXTHEIGHT(TheText,width)" 'visSectionUser, 3, visUserValue
    
    'If the text box is taller than the shape height, reduce text font size by .5 pt
    '  until it is smaller or font size = 8 pt
    sngTextHeight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID). _
        CellsSRC(242, 3, 0) 'visSectionUser, 3, visUserValue
    Do While sngTextHeight > vShapeheight And sngFontDefaultSize > sngFontMinimumSize
        sngFontDefaultSize = sngFontDefaultSize - 0.5
        sngTextHeight = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID). _
            CellsSRC(242, 3, 0)  'visSectionUser, 3, visUserValue
        AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(3, 0, 7). _
            FormulaU = sngFontDefaultSize & " pt"
    Loop
    
    Set vsoCharacters1 = Nothing

End Sub

Public Function ReturnSwimlanesInfo(Optional aryNames As Variant) As Variant
    
    Dim aryContainerIDs() As Long
    Dim iContainer As Integer
    Dim containerShp As Object
    
    Dim varOutput() As Variant, varTemp1 As Variant, varTemp2 As Variant, varTemp3 As Variant, varTemp4 As Variant
    Dim lX As Long, lY As Long
    Dim varOutputIndex As Long
    
    'Set containerShp = CreateObject("Visio.Shape")
    aryContainerIDs = AppVisio.ActivePage.GetContainers(0)  '0= visContainerIncludeNested

    For iContainer = 0 To UBound(aryContainerIDs)
        Set containerShp = AppVisio.ActivePage.Shapes.ItemFromID(aryContainerIDs(iContainer))
        If containerShp.HasCategory("Swimlane") Then
            varOutputIndex = varOutputIndex + 1
            ReDim Preserve varOutput(1 To 4, 1 To varOutputIndex)
            varOutput(1, varOutputIndex) = containerShp.Name
            varOutput(2, varOutputIndex) = containerShp.CellsSRC(1, 1, 1)   'visSectionObject, visRowXFormOut, visXFormPinY
            varOutput(3, varOutputIndex) = containerShp.Text
            varOutput(4, varOutputIndex) = containerShp.ID
            Debug.Print
        End If
    Next
    
    For lY = LBound(varOutput, 2) To UBound(varOutput, 2) - 1
        For lX = lY + 1 To UBound(varOutput, 2)
            If varOutput(2, lY) < varOutput(2, lX) Then
                varTemp1 = varOutput(1, lX)
                varTemp2 = varOutput(2, lX)
                varTemp3 = varOutput(3, lX)
                varTemp4 = varOutput(4, lX)
                varOutput(1, lX) = varOutput(1, lY)
                varOutput(2, lX) = varOutput(2, lY)
                varOutput(3, lX) = varOutput(3, lY)
                varOutput(4, lX) = varOutput(4, lY)
                varOutput(1, lY) = varTemp1
                varOutput(2, lY) = varTemp2
                varOutput(3, lY) = varTemp3
                varOutput(4, lY) = varTemp4
            End If
        Next
    Next
    
    For lX = LBound(aryNames) To UBound(aryNames)
        AppVisio.ActivePage.Shapes.ItemFromID(varOutput(4, lX + 1)).Text = aryNames(lX)
        varOutput(3, lX + 1) = aryNames(lX)
    Next
    
    ReturnSwimlanesInfo = varOutput
    
End Function

Sub AddPhaseSeparator(sngXPos As Single, sTitle As String)
    'Insert a Phase seperator at sngXPos, with the title of sTitle
    
    Dim lShapeID As Long
    
    AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("XFUNC_U.VSS").Masters.ItemU("Separator"), sngXPos, 1
    lShapeID = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).Text = sTitle

End Sub

Sub SetSwimLaneWidth(sngWidth As Single)

    'Enable diagram services
    Dim DiagramServices As Integer
    DiagramServices = AppVisio.ActiveDocument.DiagramServicesEnabled
    AppVisio.ActiveDocument.DiagramServicesEnabled = 7   ' 7 = visServiceVersion140

    AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(1, 1, 2).FormulaU = CStr(sngWidth) & " in" 'visSectionObject, visRowXFormOut, visXFormWidth

    'Restore diagram services
    AppVisio.ActiveDocument.DiagramServicesEnabled = DiagramServices


End Sub

Function DoAutoConnect(fromShapeID As Long, toShapeID As Long, sText As String) As Long
    'Modified from: http://visguy.com/vgforum/index.php?topic=6428.0
    'The AutoConnect connector is NOT selected after it is dropped.  This sub
    '  examines all connectors to find the one just created, which allows
    '  that connector to be modified

    Dim conn1 As Object, conn2 As Object
    Dim shpFrom As Object, shpTo As Object
    
    Set shpFrom = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(fromShapeID)
    Set shpTo = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(toShapeID)
    
    'Connect
    shpFrom.AutoConnect shpTo, 0    '0=visAutoConnectDirNone
    
    'Get Connector ID
    For Each conn1 In shpFrom.FromConnects
        For Each conn2 In conn1.FromSheet.Connects
            If conn2.ToSheet.ID = shpTo.ID Then
                DoAutoConnect = conn2.FromSheet.ID
                'Modify Connector
                conn2.FromSheet.Text = sText                'Add sText to connector

            End If
        Next
    Next
    
    Set shpFrom = Nothing
    Set shpTo = Nothing
    Set conn1 = Nothing
    Set conn2 = Nothing
    
End Function
 

mick0005

Active Member
Phil, you are a beast. I am so appreciative that you took the time to write all of this!! I am trying to test it with the same worksheet that you created just to make sure it was working first before I try messing with entering my own data.

I ran into a runtime error 13, type mismatch on line 600 in the code section below.

Code:
Sub CreateHorizontalSwimLanesFromExcelData()          'Given a properly constructed worksheet, create a cross-functional flow diagram
          
          Dim aryRange() As Variant '(1,1)...(1,N)   'Process Number,  Shape Type,  Shape Text,  Lane ID, Connector Text,  Successor Index


          Dim aryContents() As Variant    '0...N
          Dim lAryRangeIndex As Long
          Dim bAllInSameVisio As Boolean
          Dim varLaneData() As Variant
          Dim lVarLaneData As Long
          
          Dim lLastDataRow As Long
          Dim sLaneName As String
          Dim varI As Variant
          Dim varK As Variant
          Dim lX As Long
          Dim lLaneCount As Long
          
          Dim lProcNum As Long
          Dim sShapeType As String
          Dim varAlign As Variant
          Dim sShapeText As String
          Dim varLane As Variant
          Dim sConnText As String
          Dim lSuccIndex As Long
          Dim varPreviousLane As Variant
          
          Dim bSkipRow As Boolean
          Dim sngXPos As Single
          Dim sngSameRowDeltaX As Single
          Dim sngDiffRowDeltaX As Single
          Dim sngDeltaX As Single
          Dim bSameRow As Boolean
          
          Dim lFromIndex As Long
          Dim lToIndex As Long
          Dim lFromShape As Long
          Dim lToShape As Long
          Dim lShapeID As Long
          
          Dim sngRightEdgePos As Single
          
10        bAllInSameVisio = True
          
20        sngXPos = 0.5
30        sngSameRowDeltaX = 1.5
40        sngDiffRowDeltaX = 1.5
          
          'Load Definition Array from activesheet
          ' A = Process Number    Unique number to identify each Shape (Phases do not get a process number)
          ' B = Shape Type:       , Phase, Process, Decision, Start/End, Document, Data
          ' C = Offset from Prev  Forces block to aligned vertically with previous block
          ' D = Shape Text        Text in the shape (Phase text at top right corner of Phase Block)
          ' E = Lane ID
          ' F = Connector Text    Text in the connector
          ' G = Successor Index   Process number for connector destination (Phases do not get a Successor Index)
          ' H =            Will be filled with ShapeID
          
50        lLastDataRow = Range("A1").CurrentRegion.Rows.Count
60        aryRange = ActiveSheet.Range("A1:H" & lLastDataRow).Value


          'Get Lanes From Loaded Data ('Uniques in column D)
70        With CreateObject("Scripting.Dictionary")
80            .CompareMode = vbTextCompare
              
              'Inventory column E, row 1 to last populated cell in column E
90            For lAryRangeIndex = LBound(aryRange) To UBound(aryRange)
100               sLaneName = aryRange(lAryRangeIndex, 5)
110               If sLaneName <> vbNullString And sLaneName <> "Lane ID" Then
120                   .Item(sLaneName) = .Item(sLaneName) + 1
130               End If
140           Next
              
              'Copy Values (Keys) and Counts (Items) to 1D arrays
150           varK = .Keys
160           varI = .Items
              
              'Copy both to 2D array
170           ReDim varLaneData(1 To 2, 1 To .Count)
180           For lX = 1 To .Count
190               varLaneData(1, lX) = varK(lX - 1)
200               varLaneData(2, lX) = varI(lX - 1)
210           Next
220       End With
          
230       If bAllInSameVisio Then
              'Is Visio already running
240           On Error Resume Next
              ' Check whether Visio is running
250           Set AppVisio = GetObject(, "Visio.Application")
260           If AppVisio Is Nothing Then
                  ' Visio is not running, create new instance
270               Set AppVisio = CreateObject("visio.Application")
280               AppVisio.Visible = True
290           End If
300       Else
              'Open new copy of Visio
310           Set AppVisio = CreateObject("visio.Application")
320           AppVisio.Visible = True
330       End If
340       On Error GoTo 0
          
          'Add New Drawing
350       AppVisio.Documents.AddEx "xfunc_u.vst", 0, 0 'visMSDefault, 0
          
360       lLaneCount = UBound(varLaneData, 2)
370       Select Case lLaneCount
          Case 0
380           Stop
              'Error or default to 1 lane ??
390       Case 1
              'Delete 1 lane
400           ActiveWindow.DeselectAll
410           ActiveWindow.Select Application.ActiveWindow.Page.Shapes.ItemFromID(6), 2   '2 = visSelect
420           Application.ActiveWindow.Selection.Cut
430       Case 2
              'Do nothing, 2 lanes present by default
440       Case Else
450           For lX = 3 To lLaneCount
460               AppVisio.ActivePage.DropIntoList _
                      AppVisio.Documents.Item(1).Masters.ItemU("Swimlane"), _
                      AppVisio.ActivePage.Shapes.ItemFromID(4), 3
470           Next
480       End Select
          
          
490       varLaneData = ReturnSwimlanesInfo(varK)     '(1,1)...(4,x)  Shape, YPos, Name,  Shape ID
          
500       For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
              'Update varLane
510           For lVarLaneData = LBound(varLaneData, 2) To UBound(varLaneData, 2)
520               If aryRange(lAryRangeIndex, 5) = varLaneData(3, lVarLaneData) Then
530                    aryRange(lAryRangeIndex, 5) = varLaneData(2, lVarLaneData)
540                   Exit For
550               End If
560           Next
570       Next
          
580       For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
              'Evaluate each data row
              
590           bSkipRow = False
              
600           lProcNum = aryRange(lAryRangeIndex, 1)
610           sShapeType = Trim(aryRange(lAryRangeIndex, 2))
620           varAlign = aryRange(lAryRangeIndex, 3)
630           sShapeText = Trim(aryRange(lAryRangeIndex, 4))
640           varLane = aryRange(lAryRangeIndex, 5)
650           sConnText = Trim(aryRange(lAryRangeIndex, 6))
660           lSuccIndex = aryRange(lAryRangeIndex, 7)
              
              'Debug.Print lAryRangeIndex & "  " & lProcNum & "  " & sShapeType & "  " & _
                  varAlign & "  " & sShapeText & "  " & varLane & "  " & sConnText & "  " & lSuccIndex


670           If lProcNum = 0 And sShapeType = vbNullString Then bSkipRow = True


680           If Not bSkipRow Then
              
                  'Calculate New Horizontal Offset
690               If sShapeType = "Phase" Or sShapeType = vbNullString Then
700                   sngDeltaX = 0
710               Else
720                   Select Case varAlign
                      Case vbNullString
                          'No entry, use default spacing
730                       If varLane = varPreviousLane Then
740                           bSameRow = True
750                           sngDeltaX = sngSameRowDeltaX
760                       Else
770                           bSameRow = False
780                           sngDeltaX = sngDiffRowDeltaX
790                       End If
800                   Case Is = 0
                          'Align with last plotted shape
810                       sngDeltaX = 0
820                   Case Is > 0, Is < 0
                          'Use entered manual offset
830                       sngDeltaX = varAlign
840                   Case Else
                          'Bad entry, use default spacing
850                       If varLane = varPreviousLane Then
860                           bSameRow = True
870                           sngDeltaX = sngSameRowDeltaX
880                       Else
890                           bSameRow = False
900                           sngDeltaX = sngDiffRowDeltaX
910                       End If
920                   End Select
930               End If
940               sngXPos = sngXPos + sngDeltaX
                  
                  
950               Select Case sShapeType
                  Case "Phase"
960                   sngRightEdgePos = Replace(AppVisio.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(1, 1, 2).FormulaU, " in", "")
970                   If sngRightEdgePos < sngXPos + 1.5 Then
980                       MsgBox "I have not found a way to programatically adjust the swim lane width." & vbLf & vbLf & _
                              "1) Click OK" & vbLf & _
                              "2) Switch to Visio window" & vbLf & _
                              "3) Adjust the swim lane to as wide as you think you will need" & vbLf & _
                              "4) Return to this screen and press F5", , "Widen Swimlane manually"
990                       Stop
                          'SetSwimLaneWidth sngXPos + 1.5 'Would be nice if this worked
1000                  End If
                      
1010                  AddPhaseSeparator sngXPos + 0.625, sShapeText
1020              Case "Process", "Decision", "Subprocess", "Start/End", "Document", "Data"
1030                  aryRange(lAryRangeIndex, 8) = Drop1Shape(lProcNum, sShapeType, sShapeText, sngXPos, CSng(varLane))
1040                  varPreviousLane = varLane
1050              Case Else
                      'Invalid Shape Type - do nothing
1060              End Select
                  
1070          End If
1080      Next
          
1090      SetSwimLaneWidth sngXPos + 1
          
1100      With CreateObject("Scripting.Dictionary")
1110          .CompareMode = vbTextCompare
              
              'Inventory aryRange to to get shape number for each process #
1120          For lAryRangeIndex = LBound(aryRange) To UBound(aryRange)
1130              If IsNumeric(aryRange(lAryRangeIndex, 1)) And aryRange(lAryRangeIndex, 1) <> 0 Then
1140                  .Item(aryRange(lAryRangeIndex, 1)) = aryRange(lAryRangeIndex, 8)
1150              End If
1160          Next
              
              'Copy Values (Keys) and Counts (Items) to 1D arrays
1170          varK = .Keys
1180          varI = .Items
              
              'Copy both to 2D array
1190          ReDim aryProcToShape(1 To 2, 1 To .Count)
1200          For lX = 1 To .Count
1210              aryProcToShape(1, lX) = varK(lX - 1)
1220              aryProcToShape(2, lX) = varI(lX - 1)
1230          Next
1240      End With
          


          'Connect Shapes
1250      For lAryRangeIndex = LBound(aryRange) + 1 To UBound(aryRange)
          
1260          If aryRange(lAryRangeIndex, 7) <> 0 Then    'Successor Present
1270              lToIndex = aryRange(lAryRangeIndex, 7)
1280              If aryRange(lAryRangeIndex, 1) <> 0 Then
1290                  lFromIndex = aryRange(lAryRangeIndex, 1)
1300              End If
                  
                  
1310              For lX = LBound(aryProcToShape, 2) To UBound(aryProcToShape, 2)
1320                  If lFromIndex = aryProcToShape(1, lX) Then lFromShape = aryProcToShape(2, lX)
1330                  If lToIndex = aryProcToShape(1, lX) Then lToShape = aryProcToShape(2, lX)
1340              Next
                  
                  'Debug.Print lFromIndex, lToIndex, lFromShape, lToShape
1350              lShapeID = DoAutoConnect(lFromShape, lToShape, CStr(aryRange(lAryRangeIndex, 6)))
1360              aryRange(lAryRangeIndex, 8) = lShapeID
1370          End If
1380      Next
          
1390      Set AppVisio = Nothing
          'Set vsoCharacters = Nothing
End Sub
 
Last edited:

pbornemeier

Well-known Member
I copied the code out of the post and it ran without error against the data that I had on my original worksheet.
When I copied the data from the post to a new input worksheet and ran it against the pasted code I got the same error.
Edit the pasted input worksheet as follows:
The header row got split into 2 rows. It is a single row in the thread, but when pasted is split into 2 rows. Edit A1 to contain Process Number and G1 to contain Successor Index
The row that contains '1st Level Support' in column E should be row 2
Manually change the cells that contain only asterisks to empty cells (search and replace sees * as a wildcard and it replaces everything)
The error came from the code trying to make "Number" that is in the pasted row #2 into a long variable type.
After doing that I was able to run the pasted code and pasted data without error.
Please let me know if/how that works for you.
 

mick0005

Active Member
There we go! It was the asterisks. I had actually already fixed the headers because I noticed the merging when I pasted it over. I didn't realize I had to clear the asterisks, though.

This is looking really great. I'm insanely impressed.

1. Is there any intuitive way to know what to set for the offset values besides trial and error?
2. When the successor index needs to skip a number within the same LaneID, the arrows are a bit difficult to follow. Since they are connecting to the same connection point as the closest predecessor, it is a bit confusing. Any way for it to connect to a different connection point? I think it would make the flow easier to follow.
 

pbornemeier

Well-known Member
1. I cannot think of a way to determine the offset values, other than through trial and error.
2. In the example above, in the bottom lane could be "fixed" by offsetting every other shape down 1/8 of an inch, code could be written for that (I think) but it cannot say if that "fix" would work in all circumstances. I will look for a solution.
 

mick0005

Active Member
Thanks, Phil.

I can manage to deal with these 2 issues and can always just move the shapes manually in visio for those rare situations where the flow needs to skip a shape.

If you have any epiphanies and feel like modifying anything, I won't argue with that :)

I will be testing this more with my real world processes soon and I will report back on the outcomes.

Thanks again!
Mike
 

yash1978

New Member
Hi Phil,

Thank You! this code really helped me put my extensive process maps together. I was wondering if you were able to determine how to extend the swimlane width basis the content or processing steps for each lane ID?

Also is there a way that the processing box may have another processing box right underneath, with the application name where the processing step is being performed?

Much appreciate all the help you may be able to provide.
 

manuelsrinivas

New Member
Hi Phil,

Greetings from Srinivasan Manuel...

Thanks a ton for the code, have u tried fixing the swimlane resizing anf offset issued ?., If yes, request you to share the code.
 

manuelsrinivas

New Member
Hi Phil,

Greetings from Srinivasan Manuel...

Thanks a ton for the code, have u tried fixing the swimlane resizing and offset issue ?., If yes, request you to share the code.
 

Some videos you may like

This Week's Hot Topics

  • Get External Data (long shot question!)
    This is likely a long shot but I am wondering if it is at all possible for Excel to somehow 'change' the contents of a URL that is being linked to...
  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • Cell Formatting
    Good Morning, I need to format a few different cells in the following manners: A1 has to always add a colon (:) after whatever is typed in by a...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • Workbook_Change stopped working !
    I am working on an app to speed up & automate processing of Credit Cards statements. After data is input from a CSV file, it is presented to the...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
Top