Position Shapes in Visio based on External Data

I have a set of coordinates (northing and easting) and data associated with each coordinate that I would like to display in visio. I would like to:
- Link the data from excel dynamically
- add a shape for each line in the spread sheet based on the data (northing, easting)
- edit the shapes based on other shape data (change the color of the shape to red based on shape data criteria)
- label the shape with the unique ID "Pile"
- have all of the data from excel as shape data that can be viewed when published or exported to PDF.

I'm new to using visio, but have been able to link the data in visio, but am not sure where to start on the other requirements.

I've attached the spread sheet I am using

 Spreadsheet-visio.xlsx
j_thompsonAsked:
Who is Participating?

Improve company productivity with a Business Account.Sign Up

x
 
Arno KosterConnect With a Mentor Commented:
you can start with this code and elaborate as required (fill in your specific shape(s), play with shape placement etc)

Sub export_to_visio()
Dim x As Double
Dim y As Double
Dim x_min As Double
Dim y_min As Double
Dim x_dst As Double
Dim y_dst As Double
Dim visio_app As Object
Dim visio_page As Object
Dim shape1 As Object
Dim row As Range
Dim result As Object

Const visSectionObject = 1
Const visRowFill = 3
Const visFillForegnd = 0
Const visRowXFormOut = 1
Const visXFormHeight = 3
Const visXFormWidth = 2

    '-- start visio
    Set visio_app = CreateObject("visio.application")
    visio_app.Visible = True
    
    '-- add document
    visio_app.Documents.AddEx "", visMSDefault, 0
    Set visio_page = visio_app.activepage
    
    '-- prepare shapes
    Set shape1 = visio_page.DrawRectangle(0, 0, 0, 0)
    shape1.CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "6.26 mm"
    shape1.CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "22.393166287016 mm"
    
    x_min = WorksheetFunction.Min(Range("C:C"))
    y_min = WorksheetFunction.Min(Range("D:D"))
    x_dst = WorksheetFunction.Max(Range("C:C")) - x_min
    y_dst = WorksheetFunction.Max(Range("D:D")) - y_min
    
    '-- parse excel data
    For Each row In UsedRange.Rows
        
        '-- skip header row
        If row.Cells(1) <> "Pile" Then
            
            '-- set coordinates
            x = 5 * (row.Cells(3) - x_min) / x_dst
            y = 5 * (row.Cells(4) - y_min) / y_dst
                    
            '-- add shape
            Set result = visio_page.Drop(shape1, x, y)
            
            '-- add name & label
            result.name = row.Cells(1).Text
            result.Characters.begin = 0
            result.Characters.End = 0
            result.Characters.Text = row.Cells(1).Text
            
            '-- add coloring
            If row.Cells(10).Text = "YES" Then result.CellsSRC(visSectionObject, visRowFill, visFillForegnd).FormulaU = "2"
            
            '-- add custom properties
            For prop = 1 To 10
                add_property result, Cells(1, prop), row.Cells(prop)
            Next prop
       
        End If
        
    Next row
    
    '-- remove template shape
    shape1.Delete
    

    visio_app.Visible = True


End Sub

Sub add_property(shape As Object, name As String, value As String)
Const visSectionProp = 243
Const visRowLast = -2
Const visTagDefault = 0
Const visCustPropsLabel = 2
Const visCustPropsType = 5
Const visCustPropsFormat = 3
Const visCustPropsLangID = 14
Const visCustPropsCalendar = 15
Const visCustPropsPrompt = 1
Const visCustPropsValue = 0
Const visCustPropsSortKey = 4

    intPropRow = shape.addrow(visSectionProp, visRowLast, visTagDefault)
    shape.CellsSRC(visSectionProp, intPropRow, visCustPropsLabel).FormulaU = """" & name & """"
    'shape.CellsSRC(visSectionProp, intPropRow, visCustPropsType).FormulaU = "0"
    'shape.CellsSRC(visSectionProp, intPropRow, visCustPropsFormat).FormulaU = ""
    'shape.CellsSRC(visSectionProp, intPropRow, visCustPropsLangID).FormulaU = "1043"
    'shape.CellsSRC(visSectionProp, intPropRow, visCustPropsCalendar).FormulaU = ""
    'shape.CellsSRC(visSectionProp, intPropRow, visCustPropsPrompt).FormulaU = ""
    shape.CellsSRC(visSectionProp, intPropRow, visCustPropsValue).FormulaU = """" & value & """"
    'shape.CellsSRC(visSectionProp, intPropRow, visCustPropsSortKey).FormulaU = ""


End Sub

Open in new window

0
 
Arno KosterCommented:
This code is to be placed in the 'horizontal' worksheet and takes a couple of minutes to complete
0
 
j_thompsonAuthor Commented:
Wow!! that is perfect! thanks so much!!!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.