Solved

Position Shapes in Visio based on External Data

Posted on 2011-03-04
3
1,715 Views
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

 Spreadsheet-visio.xlsx
0
Comment
Question by:j_thompson
  • 2
3 Comments
 
LVL 19

Accepted Solution

by:
akoster 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
            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
 
LVL 19

Expert Comment

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

Author Closing Comment

by:j_thompson
ID: 35059245
Wow!! that is perfect! thanks so much!!!
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
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…

943 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

Need Help in Real-Time?

Connect with top rated Experts

4 Experts available now in Live!

Get 1:1 Help Now