Page 1 of 2 12 LastLast
Results 1 to 10 of 14

Thread: Create Visio Horizontal Swimlane from Excel ActiveSheet
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Create Visio Horizontal Swimlane from Excel ActiveSheet

    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

    <b>Sheet3</b><br /><br /><table border="1" cellspacing="0" cellpadding="0" style="font-family:Calibri,Arial; font-size:11pt; background-color:#ffffff; padding-left:2pt; padding-right:2pt; "> <colgroup><col style="font-weight:bold; width:30px; " /><col style="width:58px;" /><col style="width:65px;" /><col style="width:61px;" /><col style="width:247px;" /><col style="width:122px;" /><col style="width:71px;" /><col style="width:67px;" /></colgroup><tr style="background-color:#cacaca; text-align:center; font-weight:bold; font-size:8pt; "><td >*</td><td >A</td><td >B</td><td >C</td><td >D</td><td >E</td><td >F</td><td >G</td></tr><tr style="height:55px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >1</td><td style="text-align:center; ">Process<br />Number</td><td >Shape Type</td><td style="text-align:center; ">Offset from Previous</td><td >Shape Text</td><td >Lane ID</td><td style="text-align:center; ">Connector Text</td><td style="text-align:center; ">Successor<br />Index</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >2</td><td >*</td><td >*</td><td >*</td><td >*</td><td >1st Level Support</td><td >*</td><td >*</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >3</td><td >*</td><td >*</td><td >*</td><td >*</td><td >Advanced Support</td><td >*</td><td >*</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >4</td><td >*</td><td >*</td><td >*</td><td >*</td><td >Engineering</td><td >*</td><td >*</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >5</td><td style="text-align:center; ">1</td><td >Start/End</td><td >*</td><td >Receive Complaint</td><td >1st Level Support</td><td >*</td><td style="text-align:center; ">2</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >6</td><td style="text-align:center; ">2</td><td >Process</td><td >*</td><td >Log Complaint</td><td >1st Level Support</td><td >*</td><td style="text-align:center; ">3</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >7</td><td style="text-align:center; ">3</td><td >Process</td><td >*</td><td >Review problem DB</td><td >1st Level Support</td><td >*</td><td style="text-align:center; ">4</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >8</td><td style="text-align:center; ">4</td><td >Decision</td><td >*</td><td >Known Problem ?</td><td >1st Level Support</td><td style="text-align:center; ">Yes</td><td style="text-align:center; ">5</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >9</td><td >*</td><td >*</td><td >*</td><td >*</td><td >*</td><td style="text-align:center; ">No</td><td style="text-align:center; ">7</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >10</td><td style="text-align:center; ">5</td><td >Process</td><td >*</td><td >Inform Customer of Fix</td><td >1st Level Support</td><td >*</td><td style="text-align:center; ">6</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >11</td><td style="text-align:center; ">6</td><td >Start/End</td><td >*</td><td >Close Out Log</td><td >1st Level Support</td><td >*</td><td >*</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >12</td><td style="text-align:center; ">7</td><td >Process</td><td style="text-align:center; ">-6</td><td >Investigate Problem</td><td >Advanced Support</td><td >*</td><td style="text-align:center; ">8</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >13</td><td style="text-align:center; ">8</td><td >Decision</td><td >*</td><td >Workaround Found?</td><td >Advanced Support</td><td style="text-align:center; ">Yes</td><td style="text-align:center; ">9</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >14</td><td >*</td><td >*</td><td >*</td><td >*</td><td >*</td><td style="text-align:center; ">No</td><td style="text-align:center; ">11</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >15</td><td style="text-align:center; ">9</td><td >Process</td><td >*</td><td >Update Problem DB</td><td >Advanced Support</td><td >*</td><td style="text-align:center; ">10</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >16</td><td style="text-align:center; ">10</td><td >Process</td><td >*</td><td >Inform Customer of Workaround</td><td >Advanced Support</td><td >*</td><td style="text-align:center; ">6</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >17</td><td style="text-align:center; ">11</td><td >Process</td><td style="text-align:center; ">-6</td><td >Investigate Severity</td><td >Engineering</td><td >*</td><td style="text-align:center; ">12</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >18</td><td style="text-align:center; ">12</td><td >Decision</td><td >*</td><td >Severity ?</td><td >Engineering</td><td style="text-align:center; ">Severe</td><td style="text-align:center; ">13</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >19</td><td >*</td><td >*</td><td >*</td><td >*</td><td >*</td><td style="text-align:center; ">Routine</td><td style="text-align:center; ">14</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >20</td><td style="text-align:center; ">13</td><td >Process</td><td >*</td><td >Add Critical Patch Request</td><td >Engineering</td><td >*</td><td style="text-align:center; ">15</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >21</td><td style="text-align:center; ">14</td><td >Process</td><td >*</td><td >Add Change Request for Next Release</td><td >Engineering</td><td >*</td><td style="text-align:center; ">15</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >22</td><td style="text-align:center; ">15</td><td >Process</td><td >*</td><td >Update Problem DB</td><td >Engineering</td><td >*</td><td style="text-align:center; ">16</td></tr><tr style="height:18px ;" ><td style="font-size:8pt; background-color:#cacaca; text-align:center; " >23</td><td style="text-align:center; ">16</td><td >Process</td><td >*</td><td >Inform Customer of Status</td><td >Engineering</td><td >*</td><td style="text-align:center; ">6</td></tr></table> <br /><br /><span style="font-family:Arial; font-size:9pt; font-weight:bold;background-color:#ffffff; color:#000000; ">Excel tables to the web >> </span><a style ="font-family:Arial; font-size:9pt; color:#fcf507; background-color:#800040; font-weight:bold;" href="http://www.excel-jeanie-html.de/index.php?f=1" target="_blank"> Excel Jeanie HTML 4 </a>

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  2. #2
    Board Regular
    Join Date
    Feb 2011
    Location
    Singapore
    Posts
    406
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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 by mick0005; Jul 5th, 2015 at 11:08 PM.
    Need help with displaying your sheet properly?

    If you do not know how to install and how to use HTML Mr.Excel Maker.. click the link http://www.mrexcel.com/forum/2545970-post2.html



  3. #3
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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.
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  4. #4
    Board Regular
    Join Date
    Feb 2011
    Location
    Singapore
    Posts
    406
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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.
    Need help with displaying your sheet properly?

    If you do not know how to install and how to use HTML Mr.Excel Maker.. click the link http://www.mrexcel.com/forum/2545970-post2.html



  5. #5
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    3,659
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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.
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  6. #6
    Board Regular
    Join Date
    Feb 2011
    Location
    Singapore
    Posts
    406
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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
    Need help with displaying your sheet properly?

    If you do not know how to install and how to use HTML Mr.Excel Maker.. click the link http://www.mrexcel.com/forum/2545970-post2.html



  7. #7
    New Member
    Join Date
    Sep 2015
    Posts
    1
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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.

  8. #8
    New Member
    Join Date
    Feb 2016
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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.

  9. #9
    New Member
    Join Date
    Feb 2016
    Posts
    2
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    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.

  10. #10
    New Member
    Join Date
    Sep 2016
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: Create Visio Horizontal Swimlane from Excel ActiveSheet

    I have below error, how can i solve?


    Run-time error '-2032465766 (86db089a)'

Some videos you may like

User Tag List

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •