Create Visio document from Excel using VBA

[bydganwil]

Hi there,

I have a spreadsheet with 20 rows of data with just 1 column. I need to create a visio document for each row and display the data within it. I am not concerned about how the data is displayed within Visio.

I hope somebody can help.

Rob

 

[pbornemeier]

Automating Diagrams with Visio « Boxes and Arrows has a good discussion on how to create a flowchart from an Excel file.
I want to revisit my semi-automated version in the future, but can't right now.

 

[cemdemir]

thank you phil, i hope you will revisit near future

 

[Sroslund]

Hey Phil,
First off thanks for being so generous with your knowledge!! I copied and slightly manipulated your code above but for some reason when i generate the objects in Visio it is not adding the data in each row for each object. It only adds it to about 5 out of the 30 I have in my list. Here is what I did to your code (I just changed the object stencils)

Any ideas why it is not working for all lines?

[h=1]Sub VisioFromExcel()

Dim AppVisio As Object
Dim vsoCharacters1 As Visio.Characters
Dim lX As Long
Dim dXPos As Double
Dim dYPos As Double

'Const visSectionCharacter = 3
'Const visCharacterSize = 7

Set AppVisio = CreateObject("visio.application")
AppVisio.Visible = True

AppVisio.Documents.AddEx "", visMSDefault, 0 'Open Blank Visio Document
AppVisio.Documents.OpenEx "netlme_u.vss", visOpenRO + visOpenDocked 'Add Netlme Stencil

dXPos = AppVisio.ActivePage.PageSheet.Cells("PageWidth") / 2
dYPos = AppVisio.ActivePage.PageSheet.Cells("PageHeight") / 2

For lX = 1 To Cells(Rows.Count, 1).End(xlUp).Row


AppVisio.Windows.ItemEx(1).Activate
AppVisio.ActiveWindow.Page.Drop AppVisio.Documents.Item("NETLME_U.VSS").Masters.ItemU("City"), dXPos, dYPos

Set vsoCharacters1 = AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lX).Characters
vsoCharacters1.Begin = 0
vsoCharacters1.End = 0
vsoCharacters1.Text = CStr(Cells(lX, 1).Value)

AppVisio.ActiveWindow.Page.Shapes.ItemFromID(lX).CellsSRC(visSectionCharacter, 0, visCharacterSize).FormulaU = "12 pt"


Next

Set AppVisio = Nothing

End Sub[/h]

 

[ConfusedSoul]

Hi Im in dire need of help to implement this requirement. I have


1) Excel data headers are as below:


A1: Name
B1: Description
C1: Days
D1: Times
E1: Timezone


2) Starting from second row, for each row of data, a visio shape should be generated.
3) This is how the visio backend code of the required shape look like






'Main outer rectangle/master container
Dim MasterContainerShp As Visio.Shape
Set MasterContainerShp = ActivePage.DrawRectangle(2, 1, 8, 4)


Dim DescriptionBoxShp As Visio.Shape
Set DescriptionBoxShp = ActivePage.DrawRectangle(2, 3.5, 8, 2)

Dim JobnameShp As Visio.Shape
Set JobnameShp = ActivePage.DrawRectangle(2, 3.5, 8, 4)


Dim JobDaysOfExecution As Visio.Shape
Set JobDaysOfExecution = ActivePage.DrawRectangle(2, 1.5, 4, 2)

Dim JobTimingShp As Visio.Shape
Set JobTimingShp = ActivePage.DrawRectangle(4, 1.5, 6, 2)

Dim JobTimeZone As Visio.Shape
Set JobTimeZone = ActivePage.DrawRectangle(6, 1.5, 8, 2)


4) This is exactly how the shape should be. There is an outer rectangle within which there are subshapes
5) From second row, value in column 'A' should go as content in JobnameShp
Value in column B goes to DescriptionBoxShp
value in column c goes to JobDaysOfExecution
value in D goes to JobTimingShp and offcourse E column data goes to JobTimeZone


6) Similar process to be repeated for all rows in excel.
7) All visio figures needed on the same page in a nonoverlapping fashion.

 

[LEG_END]

I understand this is a old thread can someone advise on if its possible to create a visio diagram with shapes containing the headings across the top of the table, and the main body contains details of connections between the shapes (e.g. if it has a number then it has a connection, that connection number is the first column.

bop dev med can
hte10-200 01
hte10-201 01
hte10-202 01
hte10-203 01

 

[Rafaelete]

Hi Phil,

I´m trying to rename a bunch of visio inside a certain path using information in an excel. Where the first column (column A) selects the current word I´m looking for in the visio and the second column (column B) the word that I want it to be replace.

I have been able to do this, but is going one sheet at a time, taking too long. How can I make it so it makes the changes on the entire visio at once. I found some code that does this, but only for one visio and for the words you asign in the macro.

This is the code to rename a bunch of visio:

On Error GoTo CambiarTextoEnFicheroVisio_Error

Dim aVisio As Object ' Visio.Application
Dim aDocument As Object ' Visio.Document
Dim I As Integer
Dim iBegin As Integer
Dim iPage As Integer
Dim iTextosASustituir As Integer
Dim sFileNamePdf As String
Dim sAux As String
Dim wcount As Long

Dim visPg As Visio.Page
Dim visShp As Visio.Shape

Dim strTel_old As String
Dim strTel_new As String

strTel_old = "nadad"
strTel_new = "dasda"

' Obtener documento
Set aVisio = CreateObject("Visio.Application")

' Set aDocument = aVisio.Documents.OpenEx(FileName:=sFileName, Flags:=Visio.visOpenRW)
Set aDocument = aVisio.Documents.OpenEx(filename:=sFileName, Flags:=visOpenRW)


' Recorrerse todas las páginas


For Each visPg In aVisio.Pages
For Each visShp In visPg.Shapes
If visShp.Text = strTel_old Then
visShp.Text = strTel_new
End If
Next
Next

Sheets("Datos2").Activate
Range("E1").End(xlDown).Offset(1, 0).Value = wcount
Worksheets("Narrativas").Range("E3:E200").Value = Worksheets("Datos2").Range("E3:E200").Value
Sheets("Reemplazos").Activate

aDocument.SaveAs NewNewVisioName(sFileName)
aDocument.Close
aVisio.Quit
Set aVisio = Nothing

CambiarTextoEnFicheroVisio_Exit:
Exit Sub

CambiarTextoEnFicheroVisio_Error:
MsgBox Err.Description, vbCritical, "CambiarTextoEnFicheroVisio"
Resume CambiarTextoEnFicheroVisio_Exit

End Sub





This is the code that does the rename without needing to go to each sheet:

Dim visDoc As Visio.Document
Dim visPg As Visio.Page
Dim visShp As Visio.Shape
Dim filename As String
Dim strTel_old As Range
Dim strTel_new As Range


Worksheets("Reemplazos").Activate
strTel_old = Worksheets("Reemplazos").Range("B:B")
strTel_new = Worksheets("Reemplazos").Range("C:C")

'You have to loop through the files in your directorie(s), but I'm not good with file operations, sth with Dir
filename = "C:\Users\rriveragarrido\Desktop\Proyectos\Proyecto solaris (endesa) (PROPIO)\prueba macros\ZZZ\Narrativas antiguas\1038\1038_FLC_OTC.RC.01.01.END.GEN_ESP_31.12.20.vsd"

' Obtener documento
Set aVisio = CreateObject("Visio.Application")

' Set aDocument = aVisio.Documents.OpenEx(FileName:=sFileName, Flags:=Visio.visOpenRW)
'Set aDocument = aVisio.Documents.OpenEx(filename:=sFileName, Flags:=visOpenRW)

Set visDoc = aVisio.Documents.OpenEx(filename, Flags:=visOpenRW)

For Each visPg In visDoc.Pages
For Each visShp In visPg.Shapes
If visShp.Text = strTel_old Then
visShp.Text = strTel_new
End If
Next
Next

End Sub




Thank you in advanced.