Position Shapes in Visio based on External Data

Posted on 2011-03-04
Last Modified: 2012-05-11
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

Question by:j_thompson
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 2
LVL 19

Accepted Solution

Arno Koster earned 500 total points
ID: 35058859
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
   = 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

    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

LVL 19

Expert Comment

by:Arno Koster
ID: 35058882
This code is to be placed in the 'horizontal' worksheet and takes a couple of minutes to complete

Author Closing Comment

ID: 35059245
Wow!! that is perfect! thanks so much!!!

Featured Post

SharePoint Admin?

Enable Your Employees To Focus On The Core With Intuitive Onscreen Guidance That is With You At The Moment of Need.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
You need to know the location of the Office templates folder, so that when you create new templates, they are saved to that location, and thus are available for selection when creating new documents.  The steps to find the Templates folder path are …
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

635 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question