Macros – Import objects from a | XML file

by Apr 2, 2024


Last year, I published this post: Macros – Sample macros to import Logical and Physical Data Models from Microsoft Visio to ER/Studio Data Architect

Today, I’ll share a script that imports a particular XML file (formerly including specific Data used to retrieve the properties required to create the Entity Relationship Diagram.

Firstly, I have created a new diagram using

Logical Data Model: GIM

Logical Data Model: GIM

Then, in this diagram, I have added specific data to the shapes I used in order to identify these objects:

Entity's Data

Entity’s Data

Attribute's Data

Attribute’s Data

Relationship's Data

Relationship’s Data

Even though the relationships are linked to the entities, I have decided to add Source & Target properties. This decision was made because the object dropped on the diagram can be linked to many different connection points belonging to various shapes (entity, attribute, PK, FK, etc.).

Finally, I exported my diagram as XML (no compression, current page):

XML export options

XML export options


The XML file is too verbose to be nicely shared as text below. You can download it from here.

Here is the script of the macro which can use this XML file:

'#Language "WWB-COM"
''MACRO TITLE: wImportDrawIO
' This macro imports Entities Attributes and relationships from a XML file
'with custom properties
' Known limitations:
'- Specific data are required to import the objects
'- Only the first page is imported
'- Compressed XML format is not supported
' Blog post:

Option Explicit

Const TITLE$ = "wImportDrawIO"
Dim MyModel As Model

Sub Main

	Begin Dialog UserDialog 720,105,TITLE,.DlgFunc ' %GRID:10,7,1,1
		Text 10,21,120,14,"File Path:",.txtFile,1
		TextBox 150,21,450,21,.edFileName
		PushButton 610,21,90,21,"Select File",.btnSelectFile
		PushButton 260,70,90,21,"Import",.btnImport
		CancelButton 380,70,90,21,.btnExit
	End Dialog
	Dim dlg As UserDialog

	If Dialog(dlg) = 0 Then Exit Sub

End Sub

Private Sub DoImport(xmlFilename$)
#Region "Variables"
	Dim diag As Diagram
	Dim MySubModel As SubModel
	Dim MyEntity As Entity
	Dim MyEntityDisplay As EntityDisplay
	Dim MyAttribute As AttributeObj
	Dim MyRelationship As Relationship
	Dim MyShape As Shape
	Dim MyShapeDisplay As ShapeDisplay

	Dim xml$
	Dim cptEntities%, cptAttributes%, cptRelationships%, cptShapes%
	Dim objStream
	Dim oXml As MSXML2.DOMDocument60
	Dim allItems, oneItem, oneNode As IXMLDOMNode
	Dim myProject$, wentity$, wtable$, wid$, wx%, wy%, ww%, wh%
	Dim wattribute$, wcolumn$, wdatatype$, wnull$, wpk As Boolean
	Dim wname$, wsource$, wtarget$, wrolename$, wstyle$

	Dim datatype$, datawidth%, nPos%, s$, nSepPos%, datascale%

	Dim StartTime!
#End Region

	StartTime = Timer

	On Error GoTo Error_detected

	' Disable Tree updates: it doesn't work on the DD treeview

	Set diag = DiagramManager.NewDiagram

#Region	"XML"
	' Load XML from UTF-8 file
	Set objStream = CreateObject("ADODB.Stream")
	objStream.CharSet = "utf-8"
	xml = objStream.ReadText()
	Set objStream = Nothing

	' Parse XML
	Set oXml = New MSXML2.DOMDocument60

	If oXml.loadXML xml Then
		Debug.Print "XML loaded"

		oXml.async = False
		oXml.setProperty "SelectionLanguage""XPath"
		Set allItems = oXml.selectNodes("//mxfile")
#End Region
		If allItems.length = 0 Then
			MsgBox "Root node not found!", vbExclamation, TITLE
			Exit Sub

			Set oneItem = oXml.selectSingleNode("mxfile/diagram")
			If oneItem Is Nothing Then
				Exit Sub
				' Get the Page name
				myProject = GetAttributeValue(oneItem, "name")
				diag.ProjectName = myProject
				diag.CopyrightYear = "" & Year(Now)

			End If
		End If

#Region "object"
		' Search specific nodes
		Set allItems = oneItem.selectNodes("mxGraphModel/root/object")

		If allItems.length = 0 Then
		   Debug.Print "Unknown path"
		   MsgBox "object not found!", vbExclamation, TITLE
			Const UNKNOWN$ = "Unknown"
			Set MyModel = diag.ActiveModel
			Set MySubModel = MyModel.ActiveSubModel

			' Name compartments are displayed 
			MySubModel.ShowEntityNameCompartment = True
			MySubModel.PrimaryKeyFont.Bold = True

			' Initialize counters
			cptEntities = 0
			cptAttributes = 0
			cptRelationships = 0
			cptShapes = 0

			' Loop all matching nodes
			For Each oneItem In allItems

				' Check if the current XML node has an attribute "TableName"
				If GetAttributeValue(oneItem, "TableName") <> "" Then

					' ENTITY
					wentity = GetAttributeValue(oneItem, "label")
					wtable = GetAttributeValue(oneItem, "TableName")
					wid = GetAttributeValue(oneItem, "id")

					' Required properties are available
					If wentity <> "" And wtable <> "" Then
						Set oneNode = oneItem.selectSingleNode("mxCell").selectSingleNode("mxGeometry")
						If Not oneNode Is Nothing Then
							wx = CInt(GetAttributeValue(oneNode, "x"))
							wy = CInt(GetAttributeValue(oneNode, "y"))
							ww = CInt(GetAttributeValue(oneNode, "width"))
							wh = CInt(GetAttributeValue(oneNode, "height"))

							wx = 0
							wy = 0
							ww = 0
							wh = 0

						End If

						' Create the Entity
						Set MyEntity = MyModel.Entities.AddEx(wx, -wy)
						Debug.Print "ENT:" & vbTab & wentity
						cptEntities += 1
						MyEntity.EntityName = wentity
						MyEntity.TableName = wtable

						Set MyEntityDisplay = MySubModel.EntityDisplays(wentity)

						' Set size
						MyEntityDisplay.HorizontalSize = ww
						MyEntityDisplay.VerticalSize = wh

						' Get object ID
						If wid <> "" Then
							' Get the main color of the object
							MyEntityDisplay.BackgroundColor = GetColor(oXml, wid)

						End If

					End If

				ElseIf GetAttributeValue(oneItem, "ColumnName") <> "" Then

					wattribute = GetAttributeValue(oneItem, "label")
					wcolumn = GetAttributeValue(oneItem, "ColumnName")
					wdatatype = GetAttributeValue(oneItem, "Datatype")
					wnull = UCase(GetAttributeValue(oneItem, "NullOption"))
					wpk = UCase(GetAttributeValue(oneItem, "IsPK")) = "TRUE"

					' Parse the datatype value
					nPos = InStr(wdatatype, "(")
					If nPos = 0 Then
						datatype = wdatatype
						datawidth = 0
						datatype = Mid(wdatatype, 1, nPos - 1)
						wdatatype = Mid(wdatatype, nPos +1, Len(wdatatype))
						nPos = InStr(wdatatype, ")")
						s = Mid(wdatatype, 1, nPos - 1)
						nSepPos = InStr(s, ",")
						If nSepPos = 0 Then
							datawidth = Mid(s, 1, nPos - 1)
							datascale = 0
							datawidth = Mid(s, 1, nSepPos - 1)
							datascale = Mid(s, nSepPos + 1, Len(wdatatype))
						End If
					End If

					' Create the Attribute
					Set MyAttribute = MyEntity.Attributes.Add(wattribute, wpk)
					Debug.Print "ATT:" & vbTab & MyAttribute.AttributeName
					cptAttributes += 1

					MyAttribute.ColumnName = wcolumn
					MyAttribute.Datatype = datatype
					MyAttribute.DataLength = datawidth
					MyAttribute.DataScale = datascale
					MyAttribute.NullOption = wnull

				ElseIf GetAttributeValue(oneItem, "RelationshipName") <> "" Then
					wname = GetAttributeValue(oneItem, "RelationshipName")
					wsource = GetAttributeValue(oneItem, "Source")
					wtarget = GetAttributeValue(oneItem, "Target")
					wrolename = GetAttributeValue(oneItem, "Rolename")
					wstyle = GetAttributeValue(oneItem.selectSingleNode("mxCell"), "style")

					' Required properties are available
					If wname <> "" And wsource <> "" And wtarget <> "" Then
						If wrolename = "" Then
							' Create the Relationship
'							Set MyRelationship = MyModel.Relationships.Add(wsource, wtarget, GetRelationshipType(wstyle))
							Set MyRelationship = MyModel.Relationships.AddWithUnification(wsource, wtarget, GetRelationshipType(wstyle))


							' Create the Relationship with a specific Attribute name
							Set MyRelationship = MyModel.Relationships.AddWithRoleName(wsource, wtarget, GetRelationshipType(wstyle), wrolename)

						End If

						If Not MyRelationship Is Nothing Then
							MyRelationship.Name = wname
							Debug.Print "RS: " & vbTab & wname
							cptRelationships += 1

						End If

					End If

					' UNKNOWN: Creating shape is possible
					wname = GetAttributeValue(oneItem, "label")

					' Required properties are available
					If wname <> "" Then
						Set oneNode = oneItem.selectSingleNode("mxCell").selectSingleNode("mxGeometry")
						If Not oneNode Is Nothing Then
							wx = CInt(GetAttributeValue(oneNode, "x"))
							wy = CInt(GetAttributeValue(oneNode, "y"))
							ww = CInt(GetAttributeValue(oneNode, "width"))
							wh = CInt(GetAttributeValue(oneNode, "height"))

							wx = 0
							wy = 0
							ww = 0
							wh = 0

						End If

						If ww <> 0 And wh <> 0 Then

							Set MyShape = MyModel.Shapes.AddWithPosition(wname, wname, 2, wx, -wy)
							Debug.Print "SH: " & vbTab & MyShape.Name
							cptShapes += 1

							Set MyShapeDisplay = MySubModel.ShapeDisplays(MyShape.Name)

							If Not MyShapeDisplay Is Nothing Then
								' Set size
								MyShapeDisplay.HorizontalSize = ww
								MyShapeDisplay.VerticalSize = wh
								' Justification
								MyShapeDisplay.HorizontalJustification = 2 ' Center
								MyShapeDisplay.VerticalJustification = 2 ' Middle

							End If

						End If

					End If

				End If

#End Region

		End If

		MsgBox "Import completed! " & Format((Timer - StartTime) / 86400, "hh:mm:ss") & vbCrLf & vbCrLf & cptEntities & " elements created" & vbCrLf & cptAttributes & " attributes created" & vbCrLf & cptRelationships & " relationships created" & vbCrLf & cptShapes & " shapes created", vbInformation, TITLE

		MsgBox "XML can not be loaded!" & vbCrLf & xmlFilename, vbExclamation, TITLE

	End If

	Exit Sub

	Debug.Print "Error occured!" & IIf(DiagramManager.GetLastErrorCode <> 0, vbCrLf & DiagramManager.GetLastErrorString(), "")
	Resume Next

End Sub

Private Function GetRelationshipType%(style$)

	' Need to be extended with the other shapes you may use
	If InStr(style, "endArrow=ERzeroToMany;startArrow=ERzeroToOne;") > 0 Then
		GetRelationshipType = 3

	ElseIf InStr(style, "endArrow=ERzeroToMany;startArrow=ERmandOne;") > 0 Then
		GetRelationshipType = 1

		GetRelationshipType = 2

	End If

End Function

Private Function GetColor&(ByRef oXml As MSXML2.DOMDocument60, id$)

	Dim selectedNodes, node As IXMLDOMNode
	Dim s$

	GetColor = vbWhite

	' Search the nodes linked to the Object
	Set selectedNodes = oXml.selectNodes("//mxCell[@parent='" & id & "']")

	' Loop through the nodes
	For Each node In selectedNodes
		s = GetAttributeValue(node, "style")
'		s = Mid(s, InStr(s, "strokeColor=") + 13)
		s = Mid(s, InStr(s, "fillColor=") + 11)

		s = Left(s, InStr(s, ";") - 1)
		'Debug.Print s

		If Len(s) = 6 Then
			GetColor = RGB(Val("&H" & Mid(s, 1, 2)), Val("&H" & Mid(s, 3, 2)), Val("&H" & Mid(s, 5, 2)))
			Exit For ' Color has been found

		End If
	Next node

End Function

Private Function GetAttributeValue$(node As IXMLDOMNode, att$)
	GetAttributeValue = ""
	On Error Resume Next
	If Not node.attributes.getNamedItem(att) Is Nothing Then
		GetAttributeValue = Trim(node.attributes.getNamedItem(att).text)

	End If

End Function

#Region "DialogFunc"
Rem See DialogFunc help topic for more information.
Private Function DlgFunc(DlgItem$, Action%, SuppValue&) As Boolean
	Dim fileName$
	Dim fileExt$

	Select Case Action%
	Case 1 ' Dialog box initialization
'		DlgText("edFileName", "C:\Users\William\Documents\ERStudio Data Architect 20.1\Tests\GIM.drawio.xml")

	Case 2 ' Value changing or button pressed

		Select Case DlgItem$
			Case "btnSelectFile"
				fileName = GetFilePath(," XML File (*.xml)|*.xml|All Files (*.*)|*.*",,"Select File", 0)

				If (filename <> ""Then
					DlgText("edFileName", filename)
				End If

				DlgFunc = True
				Exit Function

			Case "btnImport"


				filename = DlgText("edFileName")

				If Len(filename) = 0 Then
						MsgBox "You must specify a file.", vbExclamation, TITLE
						DlgFunc = True
						Exit Function
					If Not FileExists(filename) Then
						MsgBox "Specified file does not exist.", vbExclamation, TITLE
						DlgFunc = True
						Exit Function
						fileExt =  Right$(filename, Len(filename) - InStrRev(filename, "."))
						If (LCase(Left(fileExt, 3)) <> "xml"Then
							MsgBox("You can only select an XML file!", vbExclamation, TITLE)
							Exit Function
						End If
					End If
				End If


				DlgFunc = False
				Exit Function

			Case "btnExit"
				DlgFunc = False
				Exit Function

		End Select
	Case 3 ' TextBox or ComboBox text changed
	Case 4 ' Focus changed
	Case 5 ' Idle
		Rem DlgFunc = True ' Continue getting idle actions
	Case 6 ' Function key
	End Select

End Function
#End Region

Private Function FileExists(ByVal fileName As StringAs Boolean

	FileExists = (Dir(filename) <> "")

End Function

This macro utilizes a reference to the Microsoft XML 6.0 library. To add this reference to your macro, follow these steps:

  1. Open the Macro Editor.
  2. Right-click in the Code Window.
  3. Select the menu item: Edit/References…

From there, you can locate and select the Microsoft XML 6.0 reference to add it to your macro environment.

Add References

Add References

The References dialog shows the current macro/module/project’s references. You need to add the Microsoft XML, v6.0 (6.0):

Microsoft XML v6.0

Microsoft XML v6.0

After adding the reference, the macro should run without raising an error for a valid data type.

Using this macro with the shared XML file, generates a model like this:

ER/Studio Data Architect model

ER/Studio Data Architect model


The macro depends on the data specified on each objects. It does the job for the XML file I shared. Using it with your own XML exports would probably require to update the macro too. So, as usual, feel free to modify the script so that it perfectly meets your expectations, or just copy the parts of this one to your own macros.


A short video which shows how to create a macro from a script in ER/Studio Data Architect: