pbornemeier
Well-known Member
- Joined
- May 24, 2005
- Messages
- 3,915
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 | |||||||||
|---|---|---|---|---|---|---|---|---|---|
| A | B | C | D | E | F | G | |||
| 1 | ProcessNumber | Shape Type | Offset from Previous | Shape Text | Lane ID | Connector Text | SuccessorIndex | ||
| 2 | * | * | * | * | 1st Level Support | * | * | ||
| 3 | * | * | * | * | Advanced Support | * | * | ||
| 4 | * | * | * | * | Engineering | * | * | ||
| 5 | 1 | Start/End | * | Receive Complaint | 1st Level Support | * | 2 | ||
| 6 | 2 | Process | * | Log Complaint | 1st Level Support | * | 3 | ||
| 7 | 3 | Process | * | Review problem DB | 1st Level Support | * | 4 | ||
| 8 | 4 | Decision | * | Known Problem ? | 1st Level Support | Yes | 5 | ||
| 9 | * | * | * | * | * | No | 7 | ||
| 10 | 5 | Process | * | Inform Customer of Fix | 1st Level Support | * | 6 | ||
| 11 | 6 | Start/End | * | Close Out Log | 1st Level Support | * | * | ||
| 12 | 7 | Process | -6 | Investigate Problem | Advanced Support | * | 8 | ||
| 13 | 8 | Decision | * | Workaround Found? | Advanced Support | Yes | 9 | ||
| 14 | * | * | * | * | * | No | 11 | ||
| 15 | 9 | Process | * | Update Problem DB | Advanced Support | * | 10 | ||
| 16 | 10 | Process | * | Inform Customer of Workaround | Advanced Support | * | 6 | ||
| 17 | 11 | Process | -6 | Investigate Severity | Engineering | * | 12 | ||
| 18 | 12 | Decision | * | Severity ? | Engineering | Severe | 13 | ||
| 19 | * | * | * | * | * | Routine | 14 | ||
| 20 | 13 | Process | * | Add Critical Patch Request | Engineering | * | 15 | ||
| 21 | 14 | Process | * | Add Change Request for Next Release | Engineering | * | 15 | ||
| 22 | 15 | Process | * | Update Problem DB | Engineering | * | 16 | ||
| 23 | 16 | Process | * | Inform Customer of Status | Engineering | * | 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
