Excel to Visio VBA

[scm160]

Hi Guys,

Trying to create an org chart for my company. Based off an excel spreadsheet of named resources.


After creating an array of resources with Name / Role / Employer / Location - I'm trying to setup a loop/select case that will create a Visio Document (landscape orientation) and will create the shapes / team title the resource is working for.

So far I've been having trouble creating shapes within my loop. Not sure why but the code provided by MSDN doesn't seem to work Shape.DrawRectangle method does not work and results in Error 429. Macro recorder does not work either getting from the Shapes window.

Ideally want I want to do is to write the titles of each Team then offset rectangle shapes below listing out the resources (while looping through the array). When that team is complete then write the next header for a different team and so on. It doesn't matter where the resources goes because the whole point is to automate the creation of these Visio rectangles with the resources' details. The user will have to manually organize them on the page in order fit everything on the page correctly.

Can anyone help me with this ???

Heres a cut of my code so far (2 hours in w/ Visio stuff).....

'loop Calls the Visio Procedure

Sub OpenVisioDoc()
     Dim VisioApp As Visio.Application
     Dim VisDoc As Visio.Document
     Dim VisShape As Visio.Shape

        Set VisioApp = CreateObject("Visio.Application")
    VisioApp.Documents.AddEx "", visMSDefault
    VisioApp.ActivePage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).FormulaU = "11 in"
    VisioApp.ActivePage.PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).FormulaU = "8.5 in"
    
    VisioApp.Windows.ItemEx("Drawing3").Activate
    VisioApp.ActiveWindow.Page.Drop VisioApp.Documents.Item("Stencil4").MasterShortcuts.ItemU("Rectangle"), 2.256152, 7.659449

    Dim UndoScopeID1 As Long
    UndoScopeID1 = VisioApp.BeginUndoScope("Size & Position 2-D")
    VisioApp.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowXFormOut, visXFormWidth).FormulaU = "1 in"
    VisioApp.EndUndoScope UndoScopeID1, True

    Dim UndoScopeID2 As Long
    UndoScopeID2 = VisioApp.BeginUndoScope("Size & Position 2-D")
    VisioApp.ActiveWindow.Page.Shapes.ItemFromID(1).CellsSRC(visSectionObject, visRowXFormOut, visXFormHeight).FormulaU = "0.5 in"
    VisioApp.EndUndoScope UndoScopeID2, True

    Dim vsoCharacters3 As Visio.Characters
    Set vsoCharacters3 = VisioApp.ActiveWindow.Page.Shapes.ItemFromID(1).Characters
    vsoCharacters3.Begin = 0
    vsoCharacters3.End = 0
    vsoCharacters3.Text = "Gunnar Gunnarson" & Chr(10) & "Analyst" & Chr(10) & "Xyz Company"
    
End Sub