Position Shapes in Visio based on External Data

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

Select all Open in new window