Excel macro to create visio flow

[amitp]

Hi All,

This is my first post in the forum.

I was trying to create a visio flow from excel vba.

i took help from below posts
https://www.mrexcel.com/forum/excel...nt-excel-using-visual-basic-applications.html
https://www.mrexcel.com/forum/excel...e-visio-flowchart-diagram-excel-row-data.html

and succeeded.

However i was unable to add arrowheads to the connectors and also could not add the desired text to the connectors.
I used autoconnect method to connect the shapes.
Can the experts help me out in achieving this or provide pointers for the same.
Any help will be appreciated.

I am working on Excel2013 and Visio Standard 2010

Here is what i did.

1. Created a stencil and (path is present in the macro code)
2. Created a spreadsheet and included all the flowchart shapes, text to be present in the shapes, to which shape it should connect
3. executed the macro

I am unable to attach the stencil but in a nutshell i just took shapes from existing visio options and assembled them in my new stencil.

macro code is below

Option Explicit

Dim AppVisio As Object

Sub CreateLinkedVisioBoxesForColumn1Data()
       
    'For each cell in column A starting in A1, create a rectangle in Visio and connect to the next box
    Dim lLastRow As Long
    Dim aryRowData() As Variant
    
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    aryRowData = Range(Cells(1, 1), Cells(lLastRow, 1)).Value
    DropStringOfBoxes aryRowData
    
    MsgBox "Complete"
    
End Sub


Sub DropStringOfBoxes(aryRange() As Variant)
    'Given an array, create a grid of vision boxes connected in order
    
    'Dim aryRange() As Variant '(1,1)...(1,N)
    Dim aryContents() As Variant    '0...N
    Dim lAryIndex As Long
    Dim lAryRangeIndex As Long
    Dim lShapeIndex As Long
    Dim sngX As Single
    Dim sngY As Single
    Dim sngDeltaX As Single
    Dim sngDeltaY As Single
    Dim lLastDropIndex As Long
    
    Dim lCurrDropIndex As Long
    Dim bAllInSameVisio As Boolean
    Dim vsoConnectorShape As Visio.Shape
      
    Dim shp1 As Object
    Dim shp2 As Object
    Dim shp3 As Object
    
    bAllInSameVisio = True
    

    

    'If using input parameter array
    For lAryIndex = LBound(aryRange, 1) To UBound(aryRange, 1)
        ReDim Preserve aryContents(0 To lAryRangeIndex)
        aryContents(lAryRangeIndex) = aryRange(lAryIndex, 1)
        lAryRangeIndex = lAryRangeIndex + 1
    Next
    
    sngDeltaX = 2.5
    sngDeltaY = 2
    sngX = 1.25
    sngY = 13.5
    If bAllInSameVisio Then
        'Is Visio already running
        On Error Resume Next
        ' Check whether PowerPoint 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
    
    'Add New Drawing
    AppVisio.Documents.AddEx "", visMSDefault, 0 'Open Blank Visio Document
    AppVisio.Documents.OpenEx "C:\Users\amitp\Documents\My Shapes\amit.vss", visOpenRO + visOpenDocked   'Add Basic Stencil
 
     Set vsoConnectorShape = Visio.ActivePage.Shapes("line2")

    For lShapeIndex = LBound(aryContents) + 1 To UBound(aryContents)
        'Calculate Position
        
        sngY = sngY - sngDeltaY
        If sngY < 1.5 Then
            sngY = 10.5
            sngX = sngX + sngDeltaX
        End If
        
'Set stencil
        AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("amit.VSS").Masters.ItemU(Cells(lShapeIndex, 2).Value), sngX, sngY
'Set primary id of shapes
        'AppVisio.ActiveWindow.Selection.PrimaryItem.ID = Cells(lShapeIndex, 1).Value
        
        lCurrDropIndex = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
        'lLastDropIndex = Cells(lShapeIndex, 4).Value
        SetShapeText lCurrDropIndex, CStr(Cells(lShapeIndex, 3).Value)
              
    Next
    
    For lShapeIndex = 1 To lCurrDropIndex
        Set shp1 = AppVisio.ActivePage.Shapes.ItemFromID(Cells(lShapeIndex, 1).Value)
        Set shp2 = AppVisio.ActivePage.Shapes.ItemFromID(Cells(lShapeIndex, 4).Value)
        If Cells(lShapeIndex, 4).Value <> "" And Cells(lShapeIndex, 4).Value > 0 Then
                shp1.AutoConnect shp2, 0, vsoConnectorShape
        End If
        'If Left(shp1, 8) = "Decision" Then
            If Cells(lShapeIndex, 6).Value <> "" And Cells(lShapeIndex, 6).Value > 0 Then
                Set shp3 = AppVisio.ActivePage.Shapes.ItemFromID(Cells(lShapeIndex, 6).Value)
                shp1.AutoConnect shp3, 4, vsoConnectorShape
            End If
        'End If
      
    Next
    
    Set AppVisio = Nothing
End Sub

Sub SetShapeText(lShapeID As Long, sEntry As String)
    'Add Text to Shape
    Dim vsoCharacters1 As Object
    
    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(2, 0, 5).FormulaU = "36 pt"   'visSectionCharacter, 0, visCharacterSize
    'AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 5, 1).formulau 'visSectionObject,visRowEvent,visEvtCellTheText
    
    Set vsoCharacters1 = Nothing

End Sub

Excel Data

Name Flow chart symbol Text Connects 1 Connect 1 Text Connects 2 Connect 2 Text
1 Start/End Start 2
2 Data Input 3
3 Process Processing 4
4 Decision Is Processing Correct 5 Yes 7 No
5 Process Correct 6
6 Subprocess Further processing 1 9
7 Process Incorrect 8
8 Subprocess Further Processing 2 4
9 Database Add to DB 10
10 Start/End End 11
11



Thanks,

 

[Derek Brown]

Re: Excel macro to create visio flow : Help needed

Hello and welcome to The Board.
You may find the following link useful - it has a Visio Forum where you may find the answer:
Visio Guy

 

[amitp]

Re: [RESOLVED] Excel macro to create visio flow : Help needed

Hi Derek,

Thanks for the pointers. I was able to resolve my issue.

I took help from below link
Visio Guy

similar problem is also explained in this forum
https://www.mrexcel.com/forum/excel...io-horizontal-swimlane-excel-activesheet.html

Now i am getting text and arrowheads in my flowchart connectors.

For the benefit of others i am explaining my solution below (for creating visio flow from excel vba)

1. Create a Stencil or use any existing one which has shapes as per your requirements (you need to add the path of stencil in the vba macro).
2. Open a spreadsheet and add details as below (Under Flow chart symbol, the values should be an exact match with the Master name in visio stencil)
3. End row is blank and should not be skipped.

Name	Flow chart symbol	Text	Connects 1	Connect 1 Text	Connects 2	Connect 2 Text
1	Start/End	Start	2
2	Data	Input	3
3	Process	Processing	4
4	Decision	Is Processing Correct	5	Yes	7	No
5	Process	Correct	6
6	Subprocess	Further processing 1	9
7	Process	Incorrect	8
8	Subprocess	Further Processing 2	4
9	Database	Add to DB	10
10	Start/End	End	11
11

<tbody>
</tbody>

Press Alt + F11 for adding vba code

Paste the Below Code

Option Explicit


Dim AppVisio As Object


Sub CreateLinkedVisioBoxesForColumn1Data()
       
    'For each cell in column A starting in A1, create a rectangle in Visio and connect to the next box
    Dim lLastRow As Long
    Dim aryRowData() As Variant
    
    lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    aryRowData = Range(Cells(1, 1), Cells(lLastRow, 1)).Value
    DropStringOfBoxes aryRowData
    
    MsgBox "Complete"
    
End Sub




Sub DropStringOfBoxes(aryRange() As Variant)
    'Given an array, create a grid of vision boxes connected in order
    
    'Dim aryRange() As Variant '(1,1)...(1,N)
    Dim aryContents() As Variant    '0...N
    Dim lAryIndex As Long
    Dim lAryRangeIndex As Long
    Dim lShapeIndex As Long
    Dim sngX As Single
    Dim sngY As Single
    Dim sngDeltaX As Single
    Dim sngDeltaY As Single
    Dim lLastDropIndex As Long
    
    Dim lCurrDropIndex As Long
    Dim bAllInSameVisio As Boolean
    Dim vsoConnectorShape As Visio.Shape
      
    Dim shp1 As Object
    Dim shp2 As Object
    Dim shp3 As Object
    
    'Dim stnobj As Visio.Document
    
    'Dim con1 As Object
    'Dim con2 As Object
    
    Dim dummy As Integer
    
    
    bAllInSameVisio = True
    


    


    'If using input parameter array
    For lAryIndex = LBound(aryRange, 1) To UBound(aryRange, 1)
        ReDim Preserve aryContents(0 To lAryRangeIndex)
        aryContents(lAryRangeIndex) = aryRange(lAryIndex, 1)
        lAryRangeIndex = lAryRangeIndex + 1
    Next
    
    sngDeltaX = 2.5
    sngDeltaY = 2
    sngX = 1.25
    sngY = 13.5
    If bAllInSameVisio Then
        'Is Visio already running
        On Error Resume Next
        ' Check whether PowerPoint 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
    
    'Add New Drawing
    AppVisio.Documents.AddEx "", visMSDefault, 0 'Open Blank Visio Document
    AppVisio.Documents.OpenEx [B]"C:\Users\amitp\Documents\My Shapes\amit.vss", visOpenRO + visOpenDocked [/B]  'Add Basic Stencil
 
 'Set stnobj = Documents.OpenEx("C:\Users\amitp\Documents\My Shapes\amit.vss", visOpenDocked)
 
     'Set vsoConnectorShape = Visio.ActivePage.Shapes("line2")
     Set vsoConnectorShape = AppVisio.ActivePage.Shapes("line2")
     


    For lShapeIndex = LBound(aryContents) + 1 To UBound(aryContents)
        'Calculate Position
        
        sngY = sngY - sngDeltaY
        If sngY < 1.5 Then
            sngY = 10.5
            sngX = sngX + sngDeltaX
        End If
        
'Set stencil
        AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("amit.VSS").Masters.ItemU(Cells(lShapeIndex, 2).Value), sngX, sngY
'Set primary id of shapes
        'AppVisio.ActiveWindow.Selection.PrimaryItem.ID = Cells(lShapeIndex, 1).Value
        
        lCurrDropIndex = AppVisio.ActiveWindow.Selection.PrimaryItem.ID
        'lLastDropIndex = Cells(lShapeIndex, 4).Value
        SetShapeText lCurrDropIndex, CStr(Cells(lShapeIndex, 3).Value)
              
    Next
    
    For lShapeIndex = 1 To lCurrDropIndex
        Set shp1 = AppVisio.ActivePage.Shapes.ItemFromID(Cells(lShapeIndex, 1).Value)
        Set shp2 = AppVisio.ActivePage.Shapes.ItemFromID(Cells(lShapeIndex, 4).Value)
        If Cells(lShapeIndex, 4).Value <> "" And Cells(lShapeIndex, 4).Value > 0 Then
            dummy = DoAutoConnect(shp1, shp2, 0, CStr(Cells(lShapeIndex, 5).Value))
        '        shp1.AutoConnect shp2, 0
        '        For Each con1 In shp1.FromConnects
        '            For Each con2 In con1.FromSheet.Connects
        '                If con2.ToSheet.ID = shp2.ID Then
        '                    con2.FromSheet.Text = "Hello"
        '                    con2.FromSheet.Cells("EndArrow").Formula = "04
                            
        '                End If
        '            Next
        '        Next
        End If
        'If Left(shp1, 8) = "Decision" Then
            If Cells(lShapeIndex, 6).Value <> "" And Cells(lShapeIndex, 6).Value > 0 Then
                Set shp3 = AppVisio.ActivePage.Shapes.ItemFromID(Cells(lShapeIndex, 6).Value)
                'shp1.AutoConnect shp3, 4, vsoConnectorShape
                dummy = DoAutoConnect(shp1, shp3, 4, CStr(Cells(lShapeIndex, 7).Value))
            End If
        'End If
      
    Next
    
    Set AppVisio = Nothing
End Sub


Sub SetShapeText(lShapeID As Long, sEntry As String)
    'Add Text to Shape
    Dim vsoCharacters1 As Object
    
    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(2, 0, 5).FormulaU = "36 pt"   'visSectionCharacter, 0, visCharacterSize
    'AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lShapeID).CellsSRC(1, 5, 1).formulau 'visSectionObject,visRowEvent,visEvtCellTheText
    
    Set vsoCharacters1 = Nothing


End Sub


Function DoAutoConnect(fromShape As Object, toShape As Object, dir As Integer, ctext As String) As Integer


Dim con1 As Object
Dim con2 As Object


fromShape.AutoConnect toShape, dir


For Each con1 In fromShape.FromConnects
    For Each con2 In con1.FromSheet.Connects
        If con2.ToSheet.ID = toShape.ID Then
            con2.FromSheet.Text = ctext
            con2.FromSheet.Cells("EndArrow").Formula = "04"
        End If
    Next
Next
DoAutoConnect = 1
End Function

Run the macro and visio flow is generated.

(Changing the title to Resolved as my original problem no more exists)

Thanks