Create Visio document from Excel using VBA

B

bydganwil

New Member
Joined
Jul 20, 2012
Messages
27
Hi there,

I have a spreadsheet with 20 rows of data with just 1 column. I need to create a visio document for each row and display the data within it. I am not concerned about how the data is displayed within Visio.

I hope somebody can help.

Rob
 
Sort by date Sort by votes
pbornemeier said:
Please provide a sample of your data including column/row references.
Click to expand...

Here are the columns:

CenteranNode column represent the center of the diagram from where all other nodes are incomin or outgoing. LinkTo tells that it is inbound to Centeral node Link from tells it is outgoing link from centeral.

[TABLE="width: 394"]
<tbody>[TR]
[TD]CenteralNode[/TD]
[TD]LinkTO[/TD]
[TD]LinkFrom[/TD]
[/TR]
[TR]
[TD]Centeral[/TD]
[TD]LinkToCentral_1[/TD]
[TD]LinkFromCenteral_1[/TD]
[/TR]
[TR]
[TD]Centeral[/TD]
[TD]LinkToCentral_2[/TD]
[TD]LinkFromCenteral_2[/TD]
[/TR]
[TR]
[TD]Centeral[/TD]
[TD]LinkToCentral_3[/TD]
[TD]LinkFromCenteral_3[/TD]
[/TR]
[TR]
[TD]Centeral[/TD]
[TD]LinkToCentral_4[/TD]
[TD]LinkFromCenteral_4[/TD]
[/TR]
[TR]
[TD]Centeral[/TD]
[TD]LinkToCentral_5[/TD]
[TD]LinkFromCenteral_5[/TD]
[/TR]
[TR]
[TD]Centeral[/TD]
[TD]LinkToCentral_6[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

We should see the diagram similar to below: All LinkTo and LinkFrom are rectangular shapes connected to Centeral node which is also a rectangular shape with straight line connecter. I have attached image of the visio diagram.







Please let me know if I can provide more details.

Thanks
Raj
 
Last edited:
Upvote 0

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
This code does what you asked. Be sure to read the comments at the start of the code.
Code: 
Sub DisplayPredSuccForSingleNode()

    'Given a 3-column array (Center, To, From) with a header row
    'H1, H2, H3                                          Plot as follows
    'C , T0, F0                                          T0           F0
    'C , T1, F1                                          T1           F1
    'C , T2, F2                                          T2     C     F2
    'C , T3, F3                                          T3           F3
    'C , T4, F4                                          T4           F4
    'All C values the same
    
    'If the error "User-defined type not defined' is displayed you must add a
    'Reference to the Visio Application to the VBA Environment as follows:
    '1) From the Microsoft Visual Basic window menu: Tools | References
    '2) Scroll to and select 'Microsoft Visio x.x Type Reference Library
    '3) Click OK.
    '4) From the Microsoft Visual Basic window menu: File | Close and Return to Microsoft Excel
    'Start code with the worksheet containing the array as the Active Worksheet
    
    Dim AppVisio As Object
    Dim lLastArrayRow As Long
    Dim vArray As Variant
    
    Dim bfound As Boolean
    Dim lX As Long, lY As Long, lZ As Long
    
    Dim sngPageWidth As Single
    Dim sngPageHeight As Single
    
    Dim vsoSelection As Visio.Selection
    Dim lngShapeIDs() As Long
    Dim lngShapeID As Long
    Dim sngShapeHCenter As Single
    Dim sngShapeVCenter As Single
    Dim sngPlotCount As Single
    Dim aryPlotted() As Variant
    
    Dim vsoCell1 As Visio.Cell
    Dim vsoCell2 As Visio.Cell
    
    Const sngShapeHeight As Single = 0.75
    Const sngShapeWidth As Single = 1.25
    
    lLastArrayRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    Set AppVisio = CreateObject("visio.application")
    AppVisio.Visible = True
    
    'Open new document
    AppVisio.Documents.AddEx "", visMSDefault, 0
    
    'Add required stencils
    AppVisio.Documents.OpenEx "basflo_u.vss", visOpenRO + visOpenDocked
    AppVisio.Documents.OpenEx "connec_u.vss", visOpenRO + visOpenDocked
    
    If AppVisio.ActivePage.Shapes.Count > 0 Then
        AppVisio.ActiveWindow.DeselectAll
        AppVisio.ActiveWindow.SelectAll
    End If
    
    Set vsoSelection = AppVisio.ActiveWindow.Selection
    Call vsoSelection.GetIDs(lngShapeIDs)
    
    sngPageWidth = AppVisio.ActivePage.PageSheet.Cells("pagewidth")
    sngPageHeight = AppVisio.ActivePage.PageSheet.Cells("pageHeight")

    vArray = ActiveSheet.Range(Cells(2, 1), Cells(lLastArrayRow, 3))
    
    ReDim Preserve aryPlotted(1 To 1)
    aryPlotted(1) = "xyzzy"
    
    For lX = LBound(vArray, 1) To UBound(vArray, 1)         '0 to X
        For lY = LBound(vArray, 2) To UBound(vArray, 2)     '0 to 2
            
            bfound = False
            
            'Compare to shapes already present (not required for this app since new page each time)
            For lngShapeID = LBound(lngShapeIDs) To UBound(lngShapeIDs)
                If AppVisio.ActivePage.Shapes(lngShapeIDs(lngShapeID)).Name = vArray(lX, lY) Then
                    bfound = True
                    Exit For
                End If
            Next
            
            If vArray(lX, lY) = vbNullString Then bfound = True 'Don't process blanks
            
            'Compare to shapes just plotted
            For lZ = LBound(aryPlotted) To UBound(aryPlotted)
                If aryPlotted(lZ) = vArray(lX, lY) Then
                    bfound = True
                    Exit For
                End If
            Next
            
            If Not bfound Then  'If not then add it
            
                sngPlotCount = sngPlotCount + 1
                ReDim Preserve aryPlotted(1 To sngPlotCount)
                aryPlotted(sngPlotCount) = vArray(lX, lY)
                Select Case lY
                Case 1
                    sngShapeHCenter = sngPageWidth / 2      'Center
                    sngShapeVCenter = sngPageHeight / 2      'Center
                Case 2
                    sngShapeHCenter = 1 * sngPageWidth / 4  'Left Column (From)
                    sngShapeVCenter = sngPageHeight * (lLastArrayRow - lX) / lLastArrayRow
                Case 3
                    sngShapeHCenter = 3 * sngPageWidth / 4  'Right Column (To)
                    sngShapeVCenter = sngPageHeight * (lLastArrayRow - lX) / lLastArrayRow
                End Select
                
                With AppVisio.ActiveWindow.Page
                    .Drop AppVisio.Documents.Item("BASFLO_U.VSS").Masters.ItemU("Process"), 2.25, 9.25
                    Set vsoSelection = AppVisio.ActiveWindow.Selection
                    Call vsoSelection.GetIDs(lngShapeIDs)
                    
                    With .Shapes.ItemFromID(lngShapeIDs(0))
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = sngShapeHCenter
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = sngShapeVCenter
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = sngShapeWidth
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = sngShapeHeight
                        .Characters.Text = vArray(lX, lY)
                        .Name = vArray(lX, lY)
                    End With
                End With
            
            End If
        Next
    Next
    
    For lX = LBound(vArray, 1) To UBound(vArray, 1)         '0 to X
        If vArray(lX, 1) <> vbNullString And vArray(lX, 2) <> vbNullString Then
        
            AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("CONNEC_U.VSS").Masters.ItemU("Line connector"), 0#, 0#
            Set vsoSelection = AppVisio.ActiveWindow.Selection
            Call vsoSelection.GetIDs(lngShapeIDs)
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .Name = "C" & CStr(2 * lX)
            End With
            
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("BeginX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 2))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("EndX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 1))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsSRC(visSectionObject, visRowLine, visLineEndArrow).FormulaU = "13"
        End If
        
        If vArray(lX, 1) <> vbNullString And vArray(lX, 3) <> vbNullString Then
            AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("CONNEC_U.VSS").Masters.ItemU("Line connector"), 0#, 0#
            Set vsoSelection = AppVisio.ActiveWindow.Selection
            Call vsoSelection.GetIDs(lngShapeIDs)
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .Name = "C" & CStr(2 * lX) + 1
            End With
            
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("BeginX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 1))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("EndX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 3))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsSRC(visSectionObject, visRowLine, visLineEndArrow).FormulaU = "13"
        End If
    Next
    
    AppVisio.ActiveWindow.DeselectAll
    
End_Sub:

    Set vsoCell1 = Nothing
    Set vsoCell2 = Nothing
    Set vsoSelection = Nothing
    Set AppVisio = Nothing
    
End Sub
 
Upvote 0
Phil,

This works perfectly fine. Quick and accurate response much appreciated. I must say that this was the best blog I have ever seen.

If possible , please let me know how to extend this if number of nodes are around 35 and may not fit on one page and need to use two page width.

Thanks
 
Last edited by a moderator:
Upvote 0
I have modified the size of the blocks and the spacing to allow 36 rows of data on a single page (1-18 rows have a single column on each side; 19-36 have double columns). If the blocks can be smaller then more could be presented on one page with some code modification.

If more that 36 rows are needed with the current code then you could split data for a single central node into 36 row chunks then run the code on each chunk. You will then get the plot for that node on multiple pages.

I designed the output with portrait format, letter-size paper in mind. If you are using larger paper or a plotter, then then modifying the code to implement a user-specified grid (currently 2 x 18) and block size (currently 0.5" X 1.2") would be possible.

Code: 
Sub DisplayPredSuccForSingleNodeMax36Rows()

    'Given a 3-column array (Center, To, From) with a header row
    'H1, H2, H3                                          Plot as follows
    'C , T0, F0                                          T0           F0
    'C , T1, F1                                          T1           F1
    'C , T2, F2                                          T2     C     F2
    'C , T3, F3                                          T3           F3
    'C , T4, F4                                          T4           F4
    'All C values the same
    '  ####  Maximum of 36 rows of data can be plotted  ####
    
    'If the error "User-defined type not defined' is displayed you must add a
    'Reference to the Visio Application to the VBA Environment as follows:
    '1) From the Microsoft Visual Basic window menu: Tools | References
    '2) Scroll to and select 'Microsoft Visio x.x Type Reference Library
    '3) Click OK.
    '4) From the Microsoft Visual Basic window menu: File | Close and Return to Microsoft Excel
    'Start code with the worksheet containing the array as the Active Worksheet
    
    Dim AppVisio As Object
    Dim lLastArrayRow As Long
    Dim vArray As Variant
    
    Dim bfound As Boolean
    Dim lX As Long, lY As Long, lZ As Long
    
    Dim sngPageWidth As Single
    Dim sngPageHeight As Single
    
    Dim vsoSelection As Visio.Selection
    Dim lngShapeIDs() As Long
    Dim lngShapeID As Long
    Dim sngShapeHCenter As Single
    Dim sngShapeVCenter As Single
    Dim sngPlotCount As Single
    Dim aryPlotted() As Variant
    Dim lPlotRows As Long
    
    Dim vsoCell1 As Visio.Cell
    Dim vsoCell2 As Visio.Cell
    
    Const sngShapeHeight As Single = 0.5
    Const sngShapeWidth As Single = 1.2
    
    lLastArrayRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    vArray = ActiveSheet.Range(Cells(2, 1), Cells(lLastArrayRow, 3))
    
    ReDim Preserve aryPlotted(1 To 1)
    aryPlotted(1) = "xyzzy"
    
    lLastArrayRow = UBound(vArray, 1)
    If lLastArrayRow > 18 Then
        lPlotRows = 18
    Else
        lPlotRows = lLastArrayRow
    End If
    
    If lLastArrayRow > 36 Then
        MsgBox "Unable to plot more than 36 rows of From/To data."
        GoTo End_Sub
    End If
    
    Set AppVisio = CreateObject("visio.application")
    AppVisio.Visible = True
    
    'Open new document
    AppVisio.Documents.AddEx "", visMSDefault, 0
    
    'Add required stencils
    AppVisio.Documents.OpenEx "basflo_u.vss", visOpenRO + visOpenDocked
    AppVisio.Documents.OpenEx "connec_u.vss", visOpenRO + visOpenDocked
    
    If AppVisio.ActivePage.Shapes.Count > 0 Then
        AppVisio.ActiveWindow.DeselectAll
        AppVisio.ActiveWindow.SelectAll
    End If
    
    Set vsoSelection = AppVisio.ActiveWindow.Selection
    Call vsoSelection.GetIDs(lngShapeIDs)
    
    sngPageWidth = AppVisio.ActivePage.PageSheet.Cells("pagewidth")
    sngPageHeight = AppVisio.ActivePage.PageSheet.Cells("pageHeight")

    For lX = LBound(vArray, 1) To UBound(vArray, 1)         '0 to X
        For lY = LBound(vArray, 2) To UBound(vArray, 2)     '0 to 2
            
            bfound = False
            
            'Compare to shapes already present (not required for this app since new page each time)
            For lngShapeID = LBound(lngShapeIDs) To UBound(lngShapeIDs)
                If AppVisio.ActivePage.Shapes(lngShapeIDs(lngShapeID)).Name = vArray(lX, lY) Then
                    bfound = True
                    Exit For
                End If
            Next
            
            If vArray(lX, lY) = vbNullString Then bfound = True 'Don't process blanks
            
            'Compare to shapes just plotted
            For lZ = LBound(aryPlotted) To UBound(aryPlotted)
                If aryPlotted(lZ) = vArray(lX, lY) Then
                    bfound = True
                    Exit For
                End If
            Next
            
            If Not bfound Then  'If not then add it
            
                sngPlotCount = sngPlotCount + 1
                ReDim Preserve aryPlotted(1 To sngPlotCount)
                aryPlotted(sngPlotCount) = vArray(lX, lY)
                Select Case lY
                Case 1
                    sngShapeHCenter = sngPageWidth / 2      'Center
                    sngShapeVCenter = sngPageHeight / 2      'Center
                Case 2
                    Select Case lLastArrayRow
                    Case Is <= 18
                        sngShapeHCenter = 1 * sngPageWidth / 4  'Left Column (From)
                        sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                    Case Is <= 36
                        If lX <= 18 Then
                            sngShapeHCenter = 1 * sngPageWidth / 6  'Left Column (From)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                        Else
                            sngShapeHCenter = 2 * sngPageWidth / 6  'Left Column (From)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + 19 - lX) / (lPlotRows + 1)
                        End If
                    Case Else

                    End Select
                Case 3
                    Select Case lLastArrayRow
                    Case Is <= 18
                        sngShapeHCenter = 3 * sngPageWidth / 4  'Right Column (To)
                        sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                    Case Is <= 36
                        If lX <= 18 Then
                            sngShapeHCenter = 4 * sngPageWidth / 6  'Right Column (To)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                        Else
                            sngShapeHCenter = 5 * sngPageWidth / 6  'Right Column (To)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + 19 - lX) / (lPlotRows + 1)
                        End If
                    Case Else
                    End Select
                End Select
                
                With AppVisio.ActiveWindow.Page
                    .Drop AppVisio.Documents.Item("BASFLO_U.VSS").Masters.ItemU("Process"), 2.25, 9.25
                    Set vsoSelection = AppVisio.ActiveWindow.Selection
                    Call vsoSelection.GetIDs(lngShapeIDs)
                    
                    With .Shapes.ItemFromID(lngShapeIDs(0))
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = sngShapeHCenter
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = sngShapeVCenter
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = sngShapeWidth
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = sngShapeHeight
                        .Characters.Text = vArray(lX, lY)
                        .Name = vArray(lX, lY)
                    End With
                End With
            
            End If
        Next
    Next
    
    For lX = LBound(vArray, 1) To UBound(vArray, 1)         '0 to X
        If vArray(lX, 1) <> vbNullString And vArray(lX, 2) <> vbNullString Then
        
            AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("CONNEC_U.VSS").Masters.ItemU("Line connector"), 0#, 0#
            Set vsoSelection = AppVisio.ActiveWindow.Selection
            Call vsoSelection.GetIDs(lngShapeIDs)
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .Name = "C" & CStr(2 * lX)
            End With
            
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("BeginX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 2))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("EndX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 1))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .CellsSRC(visSectionObject, visRowLine, visLineEndArrow).FormulaU = "13"
                .SendToBack
            End With
        End If
        
        If vArray(lX, 1) <> vbNullString And vArray(lX, 3) <> vbNullString Then
            AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("CONNEC_U.VSS").Masters.ItemU("Line connector"), 0#, 0#
            Set vsoSelection = AppVisio.ActiveWindow.Selection
            Call vsoSelection.GetIDs(lngShapeIDs)
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .Name = "C" & CStr(2 * lX) + 1
            End With
            
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("BeginX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 1))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("EndX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 3))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .CellsSRC(visSectionObject, visRowLine, visLineEndArrow).FormulaU = "13"
                .SendToBack
            End With
        End If
    Next
    
    AppVisio.ActiveWindow.DeselectAll
    
End_Sub:

    Set vsoCell1 = Nothing
    Set vsoCell2 = Nothing
    Set vsoSelection = Nothing
    Set AppVisio = Nothing
    
End Sub
 
Upvote 0
Phil,

This is exactly what I needed. Much appreciated. I have few small questions:

1. Do you know of any resource(website/blog etc) covers basics of generating visio documents using VBA? Please share any info if you can.

2. In case I have more than 36 nodes one side but less than 36 other side can I use extra space to adjust additional nodes. Means, if I have 38 incoming nodes and 34 outgoing. Where do i need to change the code to show 2 extra incoming nodes on the outgoing sides.

3. Can I use 3 different colors for central, Incoming and Outgoing shapes.

Please provide any help on these.


Thank you very much in advance!!
 
Last edited by a moderator:
Upvote 0
This modified code allows for up to 48 items on either side (2x24) and differnet colors for each group of blocks. It also allows some modification of the number of rows/block size/color by changing the constants at the top of the code.

Code: 
Sub DisplayPredSuccForSingleNode()

    'Given a 3-column array (Center, To, From) with a header row
    'H1, H2, H3                                          Plot as follows
    'C , T0, F0                                          T0           F0
    'C , T1, F1                                          T1           F1
    'C , T2, F2                                          T2     C     F2
    'C , T3, F3                                          T3           F3
    'C , T4, F4                                          T4           F4
    'All C values the same
    
    'If the error "User-defined type not defined' is displayed you must add a
    'Reference to the Visio Application to the VBA Environment as follows:
    '1) From the Microsoft Visual Basic window menu: Tools | References
    '2) Scroll to and select 'Microsoft Visio x.x Type Reference Library
    '3) Click OK.
    '4) From the Microsoft Visual Basic window menu: File | Close and Return to Microsoft Excel
    'Start code with the worksheet containing the array as the Active Worksheet
    
    '======================================================================================================
    '======================================================================================================
    Const lOutputGridMaxVerticalCount As Long = 24  'Max number of rows on either side of central element
                                                    '  If this number is increased then the height of each
                                                    '  rectangle (sngShapeHeight) must be reduced.
    Const sngShapeHeight As Single = 0.3            'The height of each rectangle
    Const sngShapeWidth As Single = 1.2             'The width of each rectangle
    Const lInputColor As Long = 255 'Red            'Color of Input blocks
    Const lCentralColor As Long = 16711680 'Blue    'Color of Central block
    Const lOutputColor As Long = 65280 'Green       'Color of Output blocks
    '======================================================================================================
    '======================================================================================================
    
    Dim AppVisio As Object
    Dim lLastArrayRow As Long
    Dim vArray As Variant
    
    Dim bfound As Boolean
    Dim lX As Long, lY As Long, lZ As Long
    
    Dim sngPageWidth As Single
    Dim sngPageHeight As Single
    
    Dim vsoSelection As Visio.Selection
    Dim lngShapeIDs() As Long
    Dim lngShapeID As Long
    Dim sngShapeHCenter As Single
    Dim sngShapeVCenter As Single
    Dim sngPlotCount As Single
    Dim aryPlotted() As Variant
    Dim lPlotRows As Long
    Dim lMaxRows As Long
    
    Dim vsoCell1 As Visio.Cell
    Dim vsoCell2 As Visio.Cell
    Dim lColor As Long
    
    Const lOutputGridMaxHorizontalCount As Long = 2 'DON'T CHANGE THIS - CODE WILL BREAK = 2
    
    lMaxRows = lOutputGridMaxHorizontalCount * lOutputGridMaxVerticalCount
    
    lLastArrayRow = Cells(Rows.Count, 1).End(xlUp).Row
    
    vArray = ActiveSheet.Range(Cells(2, 1), Cells(lLastArrayRow, 3))
    
    ReDim Preserve aryPlotted(1 To 1)
    aryPlotted(1) = "xyzzy"
    
    lLastArrayRow = UBound(vArray, 1)
    
    If lLastArrayRow > lMaxRows Then
        MsgBox "Unable to plot more than " & lMaxRows & " rows of From/To data."
        GoTo End_Sub
    End If
    
    If lLastArrayRow > lOutputGridMaxVerticalCount Then
        lPlotRows = lOutputGridMaxVerticalCount
    Else
        lPlotRows = lLastArrayRow
    End If
    
    Set AppVisio = CreateObject("visio.application")
    AppVisio.Visible = True
    
    'Open new document
    AppVisio.Documents.AddEx "", visMSDefault, 0
    
    'Add required stencils
    AppVisio.Documents.OpenEx "basflo_u.vss", visOpenRO + visOpenDocked
    AppVisio.Documents.OpenEx "connec_u.vss", visOpenRO + visOpenDocked
    
    If AppVisio.ActivePage.Shapes.Count > 0 Then
        AppVisio.ActiveWindow.DeselectAll
        AppVisio.ActiveWindow.SelectAll
    End If
    
    Set vsoSelection = AppVisio.ActiveWindow.Selection
    Call vsoSelection.GetIDs(lngShapeIDs)
    
    sngPageWidth = AppVisio.ActivePage.PageSheet.Cells("pagewidth")
    sngPageHeight = AppVisio.ActivePage.PageSheet.Cells("pageHeight")

    For lX = LBound(vArray, 1) To UBound(vArray, 1)         '0 to X (number of input rows)
        For lY = LBound(vArray, 2) To UBound(vArray, 2)     '0 to 2
            
            bfound = False
            
            'Compare to shapes already present (not required for this app since new page each time)
            For lngShapeID = LBound(lngShapeIDs) To UBound(lngShapeIDs)
                If AppVisio.ActivePage.Shapes(lngShapeIDs(lngShapeID)).Name = vArray(lX, lY) Then
                    bfound = True
                    Exit For
                End If
            Next
            
            If vArray(lX, lY) = vbNullString Then bfound = True 'Don't process blanks
            
            'Compare to shapes just plotted
            For lZ = LBound(aryPlotted) To UBound(aryPlotted)
                If aryPlotted(lZ) = vArray(lX, lY) Then
                    bfound = True
                    Exit For
                End If
            Next
            
            If Not bfound Then  'If not then add it
            
                If lLastArrayRow / 2 <> Int(lLastArrayRow / 2) Then lLastArrayRow = lLastArrayRow + 1
            
                sngPlotCount = sngPlotCount + 1
                ReDim Preserve aryPlotted(1 To sngPlotCount)
                aryPlotted(sngPlotCount) = vArray(lX, lY)
                
                Select Case lY
                Case 1
                    lColor = lCentralColor
                    sngShapeHCenter = sngPageWidth / 2       'Center
                    sngShapeVCenter = sngPageHeight / 2      'Center
                Case 2
                    lColor = lInputColor
                    Select Case lLastArrayRow
                    Case Is <= lOutputGridMaxVerticalCount  'plot in 1 column
                        sngShapeHCenter = 1 * sngPageWidth / 4  'Left Column (From)
                        sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                    Case Else
                        If lX <= lOutputGridMaxVerticalCount Then  'plot in 2 columns
                            sngShapeHCenter = 1 * sngPageWidth / 6  'Left Column (From)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                        Else
                            sngShapeHCenter = 2 * sngPageWidth / 6  'Left Column (From)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + lPlotRows + 1 - lX) / (lPlotRows + 1)
                        End If
                    End Select
                Case 3
                    lColor = lOutputColor
                    Select Case lLastArrayRow
                    Case Is <= lOutputGridMaxVerticalCount
                        sngShapeHCenter = 3 * sngPageWidth / 4  'Right Column (To)
                        sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                    Case Else
                        If lX <= lOutputGridMaxVerticalCount Then
                            sngShapeHCenter = 4 * sngPageWidth / 6  'Right Column (To)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + 1 - lX) / (lPlotRows + 1)
                        Else
                            sngShapeHCenter = 5 * sngPageWidth / 6  'Right Column (To)
                            sngShapeVCenter = sngPageHeight * (lPlotRows + lPlotRows + 1 - lX) / (lPlotRows + 1)
                        End If
                    End Select
                End Select
                
                With AppVisio.ActiveWindow.Page
                    .Drop AppVisio.Documents.Item("BASFLO_U.VSS").Masters.ItemU("Process"), 2.25, 9.25
                    Set vsoSelection = AppVisio.ActiveWindow.Selection
                    Call vsoSelection.GetIDs(lngShapeIDs)
                    
                    With .Shapes.ItemFromID(lngShapeIDs(0))
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinX).FormulaU = sngShapeHCenter
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormPinY).FormulaU = sngShapeVCenter
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = sngShapeWidth
                        .CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = sngShapeHeight
                        .Characters.Text = vArray(lX, lY)
                        .Name = vArray(lX, lY)
                        .CellsSRC(visSectionCharacter, 0, visCharacterColor).FormulaU = _
                            "THEMEGUARD(" & ConvertLongToRGBString(lColor) & ")"
                        .CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = _
                            "THEMEGUARD(" & ConvertLongToRGBString(lColor) & ")"
                    End With
                End With
            End If
        Next
    Next
    
    For lX = LBound(vArray, 1) To UBound(vArray, 1)         '0 to X
        If vArray(lX, 1) <> vbNullString And vArray(lX, 2) <> vbNullString Then
        
            AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("CONNEC_U.VSS").Masters.ItemU("Line connector"), 5#, 5#
            Set vsoSelection = AppVisio.ActiveWindow.Selection
            Call vsoSelection.GetIDs(lngShapeIDs)
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .Name = "C" & CStr(2 * lX)
            End With
            
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("BeginX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 2))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("EndX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 1))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .CellsSRC(visSectionObject, visRowLine, visLineEndArrow).FormulaU = "13"
                .SendToBack
                .CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = _
                    "THEMEGUARD(" & ConvertLongToRGBString(lInputColor) & ")"
            End With
        End If
        
        If vArray(lX, 1) <> vbNullString And vArray(lX, 3) <> vbNullString Then
            AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("CONNEC_U.VSS").Masters.ItemU("Line connector"), 4#, 5#
            Set vsoSelection = AppVisio.ActiveWindow.Selection
            Call vsoSelection.GetIDs(lngShapeIDs)
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .Name = "C" & CStr(2 * lX) + 1
            End With
            
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("BeginX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 1))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            Set vsoCell1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0)).CellsU("EndX")
            Set vsoCell2 = AppVisio.ActiveWindow.Page.Shapes(CStr(vArray(lX, 3))).CellsSRC(1, 1, 0)
            vsoCell1.GlueTo vsoCell2
            With AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lngShapeIDs(0))
                .CellsSRC(visSectionObject, visRowLine, visLineEndArrow).FormulaU = "13"
                .SendToBack
                .CellsSRC(visSectionObject, visRowLine, visLineColor).FormulaU = _
                    "THEMEGUARD(" & ConvertLongToRGBString(lOutputColor) & ")"
            End With
        End If
    Next
    
    AppVisio.ActiveWindow.DeselectAll
    
End_Sub:

    Set vsoCell1 = Nothing
    Set vsoCell2 = Nothing
    Set vsoSelection = Nothing
    Set AppVisio = Nothing
    
End Sub

Function ConvertLongToRGBString(lRGB As Long) As String
    Dim bR As Byte, bG As Byte, bB As Variant
    bR = lRGB Mod 256
    bG = Int(lRGB / 256) Mod 256
    bB = Int(lRGB / 256 / 256) Mod 256
    ConvertLongToRGBString = "RGB(" & CStr(bR) & "," & CStr(bG) & "," & CStr(bB) & ")"
End Function

As far as your questions
1) I don't know of any sites that cover this info. I suggest you turn on the macro recorder in Visio and experiment with the resulting code. Once you get it working in visio, you can run visio from Excel as I ded in this code.

2) The current code and layout would not easily allow that type of shift.

3) Color options have been added.

Generally not necessary to quote the message you are responding to unless portions if it are required for your reply.
 
Upvote 0
Thanks Phil. This helped a lot.

Color works fine. the only issue I saw was with the node which are in both inbound and outbound. I will find the solution for common node as what should be the color.

Yes, I will use reply instead of "Reply with Quote"

Thanks Again!!
 
Upvote 0
Hi Phil,

I need to create a signal flow diagram in VISIO from a excel, it would be great pleasure if you can provide the similar code as above for the following rows. Kind of signal flow diagram in visio, we are creating manually, is also shown below.

Thanks in advance

Rgds
Anurag

[TABLE="width: 440"]
<colgroup><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD="colspan: 4"]FROM
[/TD]
[TD="colspan: 4"]TO[/TD]
[/TR]
[TR]
[TD]Type
[/TD]
[TD]Shelf
[/TD]
[TD]Slot[/TD]
[TD]Port[/TD]
[TD]Type[/TD]
[TD]Shelf[/TD]
[TD]Slot[/TD]
[TD] Port
[/TD]
[/TR]
[TR]
[TD]WR8-88A[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]9[/TD]
[TD]DROP_OUT[/TD]
[TD]WR8-88A[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]4
[/TD]
[TD]ADD_IN7
[/TD]
[/TR]
[TR]
[TD]WR8-88A[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]9[/TD]
[TD]ADD_IN8[/TD]
[TD]WR8-88A[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]4[/TD]
[TD]MESH_OUT1
[/TD]
[/TR]
[TR]
[TD]WR8-88A[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]9[/TD]
[TD]MESH_OUT1[/TD]
[TD]WR8-88A[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]4[/TD]
[TD]ADD_IN7[/TD]
[/TR]
[TR]
[TD]WR8-88A[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]9[/TD]
[TD]ADD_IN7[/TD]
[TD]WR8-88A[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]4[/TD]
[TD]MESH_OUT1[/TD]
[/TR]
</tbody>[/TABLE]
 
Last edited by a moderator:
Upvote 0
Re: Create Visio 2010 document from Excel 2013 using VBA

Hi,
I am in a desperate need for an Visio MACRO.Please let me know if anyone can help. Below are my requirements.
I have an excel file with workflow steps which needs to be prepared as a VISIO diagram.
At the starting there is a start and hence macro should pick this as a start and end it when it triggers end. For each step it should prepare a box depends on Input given in the next column (Process Box or Decision Box or Data Box).
The next column (Swim lane) will give the swim lane name for which the boxes need to come.
Below is the sample doc:

Steps Description Type Swimlane
1 Start Start/End Alpha
2 abc Process Alpha
3 abc Process Alpha
4 abc Sub Process Beta
5 efd Decision Beta
6 dfe Process Gamma
7 ewgew Document Gamma
8 egtfesfes Data Alpha
9 etfe Process Alpha
10 End Start/End Gamma

I know lil bit of coding but not an expert. Appreciate if someone can help me out with this.

Regards,
Vik
 
Upvote 0
Re: Create Visio 2010 document from Excel 2013 using VBA

Horizontal or Vertical Lanes?
There are hundreds of different Could you please post a link to an image (google for "Swimlane Chart") similar to what your graph should look like.
 
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Question Question
Using VBA to create a dynamic Combo box population
Replies
1
Views
178
sxhall
S
P
  • Question Question
Document Status Screen
Replies
0
Views
89
Pestomania
P
M
  • Question Question
Data Transfer from Excel to PowerPoint and getting PDF file of PPT
Replies
1
Views
126
Sequoyah
Sequoyah
J
  • Question Question
Issues looping through excel data range when blank rows/cells are introduced.
Replies
6
Views
736
Skyybot
Skyybot
B
  • Solved
VB for Searching for ~ 20 words in a large table of text
Replies
3
Views
121
BobTheSpreadsheetBuilder
B

Forum statistics

Threads
1,224,826
Messages
6,181,192
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top