Creating an SVG file with VBA

So SVG stands for Scalable Vector Graphics as is part of HTML5 and so is best open standard for graphics.  However, when drawing curved lines the co-ordinate data is packed in an attribute called 'd' on a SVG path element and is very fiddly to manipulate.

We will set ourselves the task of creating the Union Flag of the United Kingdom, at time of writing there is still a problem with viewbox, TODO: fix viewbox. Here is the finished output


I want a number of classes to help me out.  I opened a new workbook and named the VBA project SVGHelper and add library references to Microsoft Scripting Runtime and Microsoft Xml, v6.0

First I wanted a SVGHelper.Point class.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Point"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".Point"

Private m_x As Double
Private m_y As Double

Public Sub SetPoint(ByVal dX As Double, ByVal dY As Double)
    m_x = dX
    m_y = dY
    
End Sub
Public Property Get x() As Double
    Const sSRC As String = msMODULE & ".x[PropertyGet]"
    x = m_x
End Property
Public Property Get y() As Double
    Const sSRC As String = msMODULE & ".y[PropertyGet]"
    y = m_y
End Property

Then I wanted a SVGHelper.Points class which is a collection of SVGHelper.Points, this will help us build a path step by step.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Points"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".Points"


Private mdicPoints As Scripting.Dictionary

Private Sub Class_Initialize()
    Set mdicPoints = New Scripting.Dictionary
End Sub

Public Function Count() As Long
    Count = mdicPoints.Count
End Function

Public Function Item(ByVal idx As Long) As SVGHelper.Point
    Const sSRC As String = msMODULE & ".Item"

    If idx >= mdicPoints.Count Then Err.Raise vbObjectError, sSRC, "#Bad index!"
    Set Item = mdicPoints.Item(idx)
End Function

Public Function LastPoint() As SVGHelper.Point
    Const sSRC As String = msMODULE & ".LastPoint"
    If mdicPoints.Count = 0 Then Err.Raise vbObjectError, sSRC, "#Cannot have last point if point count is zero!"
    Set LastPoint = mdicPoints.Item(mdicPoints.Count - 1)

End Function

Public Function AddPoint(ByVal dX As Double, ByVal dY As Double) As SVGHelper.Point
    Const sSRC As String = msMODULE & ".AddPoint"
    Dim oPoint As SVGHelper.Point
    Set oPoint = CreatePoint(dX, dY)
    mdicPoints.Add mdicPoints.Count, oPoint

    Set AddPoint = oPoint

End Function

Public Function CreatePoint(ByVal dX As Double, ByVal dY As Double) As SVGHelper.Point
    Const sSRC As String = msMODULE & ".CreatePoint"
    Dim oPoint As SVGHelper.Point
    Set oPoint = New SVGHelper.Point
    oPoint.SetPoint dX, dY
    
    Set CreatePoint = oPoint
    
End Function

Next I wanted a SVGHelper.SVGPath which effectively inherits from the Points class and allows the calculation of the D attribute. Also, we ship some method to generate one path from another via a transform, the union flag is quite symmetrical and if you can find the path of a small blue triangle then you have all four by reflection.

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "SVGPath"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".SvgPath"

Private moPoints As SVGHelper.Points

Private Sub Class_Initialize()
    Set moPoints = New SVGHelper.Points
End Sub

Public Function D_Attribute(Optional dLateScale As Double = 1, Optional dLateTransformX As Double = 0, Optional dLateTransformY As Double = 0) As String
    Const sSRC As String = msMODULE & ".D_Attribute"

    If moPoints.Count >= 1 Then
        Dim oMovePoint As SVGHelper.Point
        Set oMovePoint = moPoints.Item(0)
        D_Attribute = "M " & (oMovePoint.x * dLateScale) + dLateTransformX & "," & (oMovePoint.y * dLateScale) + dLateTransformY & " "
    End If
    
    Dim lPointLoop As Long
    For lPointLoop = 1 To moPoints.Count - 1
        Dim oPointLoop As SVGHelper.Point
        Set oPointLoop = moPoints.Item(lPointLoop)
        D_Attribute = D_Attribute & "L " & (oPointLoop.x * dLateScale) + dLateTransformX & "," & (oPointLoop.y * dLateScale) + dLateTransformY & " "
    Next lPointLoop
    
    

End Function

Public Function ReflectInBothXAndY() As SVGHelper.SVGPath

    Dim oNewPath As SVGHelper.SVGPath
    Set oNewPath = Me.ReflectInX
    Set oNewPath = oNewPath.ReflectInY
    Set ReflectInBothXAndY = oNewPath

End Function



Public Function ReflectInY() As SVGHelper.SVGPath

    Dim oNewPath As SVGHelper.SVGPath
    Set oNewPath = New SVGHelper.SVGPath
    
    Dim oMovePoint As SVGHelper.Point
    Set oMovePoint = moPoints.Item(0)
    oNewPath.SetMove -oMovePoint.x, oMovePoint.y

    Dim lPointLoop As Long
    For lPointLoop = 1 To moPoints.Count - 1
        Dim oPointLoop As SVGHelper.Point
        Set oPointLoop = moPoints.Item(lPointLoop)
        oNewPath.AddPoint -oPointLoop.x, oPointLoop.y, False
        
    Next lPointLoop
    
    Set ReflectInY = oNewPath
    

End Function

Public Function ReflectInX() As SVGHelper.SVGPath

    Dim oNewPath As SVGHelper.SVGPath
    Set oNewPath = New SVGHelper.SVGPath
    
    Dim oMovePoint As SVGHelper.Point
    Set oMovePoint = moPoints.Item(0)
    oNewPath.SetMove oMovePoint.x, -oMovePoint.y

    Dim lPointLoop As Long
    For lPointLoop = 1 To moPoints.Count - 1
        Dim oPointLoop As SVGHelper.Point
        Set oPointLoop = moPoints.Item(lPointLoop)
        oNewPath.AddPoint oPointLoop.x, -oPointLoop.y, False
        
    Next lPointLoop
    
    Set ReflectInX = oNewPath
    

End Function

Public Sub SetMove(ByVal dX As Double, ByVal dY As Double)
    Const sSRC As String = msMODULE & ".SetMove"
    If moPoints.Count <> 0 Then Err.Raise vbObjectError, sSRC, "#Move must be first point only!"
    
    moPoints.AddPoint dX, dY
    
End Sub

Public Sub AddPoint(ByVal dX As Double, ByVal dY As Double, ByVal bRelative As Boolean)
    Const sSRC As String = msMODULE & ".AddPoint"
    If bRelative Then Err.Raise vbObjectError, sSRC, "#Not yet implemented!"
    If moPoints.Count = 0 Then Err.Raise vbObjectError, sSRC, "#Must set move point first!"
    
    moPoints.AddPoint dX, dY
End Sub

Public Sub ClosePath()
    Const sSRC As String = msMODULE & ".ClosePath"
    If moPoints.Count = 0 Then Err.Raise vbObjectError, sSRC, "#Must set move point first!"

    Dim oFirstPoint As SVGHelper.Point
    Set oFirstPoint = moPoints.Item(0)

    moPoints.AddPoint oFirstPoint.x, oFirstPoint.y

End Sub

So I'm done with the re-useable helper classes, now I want a UnionJack class that calls into above helper classes

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "UnionJack" 
VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const msMODULE As String = gsPROJECT & ".UnionJack"

Private dSqr5 As Double
Private d2Sqr5 As Double

Private Sub Class_Initialize()
    dSqr5 = Sqr(5)
    d2Sqr5 = 2 * Sqr(5)
End Sub


'Public Function TransformElement(ByVal dScale As Double) As String
'    TransformElement = "translate(" & 30 * dScale & "," & 15 * dScale & ")"
'End Function

Public Function StPatricksCrossBlade(ByVal idx As Long) As SVGHelper.SVGPath

    Dim oBlade As SVGHelper.SVGPath
    Set oBlade = New SVGHelper.SVGPath
    
    If idx Mod 2 = 0 Then
        
        oBlade.SetMove 30, 15
        oBlade.AddPoint 30, 15 - dSqr5, False
        oBlade.AddPoint 10 + d2Sqr5, 5, False
        oBlade.AddPoint 10, 5, False
        
        oBlade.ClosePath
        
        If idx = 2 Then Set oBlade = oBlade.ReflectInBothXAndY
    
    Else
        oBlade.SetMove 30, -15
        oBlade.AddPoint 30 - d2Sqr5, -15, False
        oBlade.AddPoint 10 - d2Sqr5, -5, False
        oBlade.AddPoint 10, -5, False
    
    
        oBlade.ClosePath
        If idx = 3 Then Set oBlade = oBlade.ReflectInBothXAndY
    
    End If

    Set StPatricksCrossBlade = oBlade
End Function


Public Function BlueTriangle(ByVal bSmall As Boolean, ByVal idx As Long) As SVGHelper.SVGPath
    Const sSRC As String = msMODULE & ".BlueTriangle"
    If idx < 0 Then Err.Raise vbObjectError, sSRC, "#idx must be in set {0,1,2,3}!"
    If idx > 3 Then Err.Raise vbObjectError, sSRC, "#idx must be in set {0,1,2,3}!"

    Dim oSvgPath As SVGHelper.SVGPath
    If bSmall Then

        Set oSvgPath = MySmallerBlueTriangle
    Else
        Set oSvgPath = MyLargerBlueTriangle
    End If
    
    If idx >= 1 Then Set oSvgPath = oSvgPath.ReflectInX
    If idx >= 2 Then Set oSvgPath = oSvgPath.ReflectInY
    If idx >= 3 Then Set oSvgPath = oSvgPath.ReflectInX

    Set BlueTriangle = oSvgPath

End Function


Private Function MyLargerBlueTriangle() As SVGHelper.SVGPath

    Dim oSvgPath As SVGHelper.SVGPath
    Set oSvgPath = New SVGHelper.SVGPath

    Dim dHalfLength As Double
    dHalfLength = (25 - (3 * Sqr(5))) / 2

    oSvgPath.SetMove 5, 15
    oSvgPath.AddPoint 5, 15 - dHalfLength, False
    oSvgPath.AddPoint 5 + dHalfLength + dHalfLength, 15, False
    oSvgPath.ClosePath

    Set MyLargerBlueTriangle = oSvgPath
End Function

Private Function MySmallerBlueTriangle() As SVGHelper.SVGPath

    Dim oSvgPath As SVGHelper.SVGPath
    Set oSvgPath = New SVGHelper.SVGPath

    Dim dHalfLength As Double
    dHalfLength = 10 - (3 * (Sqr(5) / 2))

    

    oSvgPath.SetMove 30, 5
    oSvgPath.AddPoint 30, 5 + dHalfLength, False
    oSvgPath.AddPoint 30 - dHalfLength - dHalfLength, 5, False
    oSvgPath.ClosePath

    Set MySmallerBlueTriangle = oSvgPath
End Function


Public Function EnglishCross() As SVGHelper.SVGPath

    Dim oSvgPath As SVGHelper.SVGPath
    Set oSvgPath = New SVGHelper.SVGPath

    Dim x As Double, y As Double
    x = 3: y = 3
    oSvgPath.SetMove x, y
    oSvgPath.AddPoint x + 27, y, False 'out to the east point
    oSvgPath.AddPoint x + 27, y - 6, False
    oSvgPath.AddPoint x, y - 6, False
    oSvgPath.AddPoint x, y - 6 - 12, False 'now over the top north point
    oSvgPath.AddPoint x - 6, y - 6 - 12, False
    oSvgPath.AddPoint x - 6, y - 6, False
    oSvgPath.AddPoint x - 6 - 27, y - 6, False 'out to the west point
    oSvgPath.AddPoint x - 6 - 27, y, False
    oSvgPath.AddPoint x - 6, y, False
    oSvgPath.AddPoint x - 6, y + 12, False 'now under the south point
    oSvgPath.AddPoint x, y + 12, False
    oSvgPath.AddPoint x, y, False 'finish


    Set EnglishCross = oSvgPath

End Function

Finally, I want some code to manipulate an Xml document because SVG is a type of Xml (or SGML strictly)

Attribute VB_Name = "modUnionJack"
Option Explicit
Option Private Module

'* References Microsoft Scripting Runtime
'* References Microsoft XML, v6.0

Public Const gsPROJECT As String = "SVGHelper"
Private Const msMODULE As String = gsPROJECT & ".modUnionJack"


Private Sub CreateFromScratch()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim sSVGPath As String
    'sSVGPath = fso.BuildPath(ThisWorkbook.Path, "United Jack Red White And Blue VBA 2.svg")
    sSVGPath = "N:\UnionJack.svg"
    
    Dim txtOut As Scripting.TextStream
    Set txtOut = fso.CreateTextFile(sSVGPath)
    txtOut.WriteLine Chr$(60) & "?xml version=""1.0"" encoding=""UTF-8"" standalone=""no""?" & Chr$(62)
    txtOut.WriteLine Chr$(60) & "svg:svg xmlns:svg=""http://www.w3.org/2000/svg"" /" & Chr$(62)

    txtOut.Close
    Set txtOut = Nothing
    
    
    If fso.FileExists(sSVGPath) Then
    
        Dim dom As MSXML2.DOMDocument60
        Set dom = New MSXML2.DOMDocument60
        
        dom.Load sSVGPath
    
        Debug.Assert dom.parseError = 0
        
        Const csRED_STYLE As String = "fill:#cf142b;fill-opacity:1"
        Const csBLUE_STYLE As String = "fill:#00247d;fill-opacity:1"
        
        Dim xmlPaths As MSXML2.IXMLDOMNodeList
        'Set xmlPaths = dom.DocumentElement.SelectNodes("paths")
        'Debug.Assert Not xmlPaths Is Nothing
        
        'dom.setProperty "SelectionLanguage", "XPath"
        dom.setProperty "SelectionNamespaces", "xmlns:svg=""http://www.w3.org/2000/svg"""
        
        Dim xmlSVG As MSXML2.IXMLDOMElement
        Set xmlSVG = dom.SelectSingleNode("svg:svg")
        Call xmlSVG.setAttribute("viewbox", "0 0 600 300")
        'Call xmlSVG.setAttribute("width", "1200")
        'Call xmlSVG.setAttribute("height", "600")
        'Call xmlSVG.setAttribute("width", "210mm")
        'Call xmlSVG.setAttribute("height", "297mm")
        Call xmlSVG.setAttribute("version", "1.1")
        
        
        Dim xmlGTranslate As MSXML2.IXMLDOMElement
        Set xmlGTranslate = dom.createElement("svg:g")
        Call xmlGTranslate.setAttribute("id", "TranslateToCentre")
        
        Dim oUnionJack As UnionJack
        Set oUnionJack = New UnionJack
        
        '* last minute scale and transform to hard code
        Dim dScale As Double, dTransformX As Double, dTransformY As Double
        dScale = 10
        dTransformX = 300
        dTransformY = 150
        
        
        'Call xmlGTranslate.setAttribute("transform", oUnionJack.TransformElement)
        xmlSVG.appendChild xmlGTranslate
        dom.Save sSVGPath
        

        Dim xmlEnglishCross As MSXML2.IXMLDOMElement

        Dim xmlLineBreak As MSXML2.IXMLDOMText
        Set xmlLineBreak = dom.createTextNode(vbNewLine)
        
        Set xmlEnglishCross = dom.createElement("svg:path")
        Call xmlEnglishCross.setAttribute("id", "EnglishCross")
        Call xmlEnglishCross.setAttribute("style", csRED_STYLE)
        Call xmlEnglishCross.setAttribute("d", oUnionJack.EnglishCross.D_Attribute(dScale, dTransformX, dTransformY))

        xmlGTranslate.appendChild xmlEnglishCross
        xmlGTranslate.appendChild xmlLineBreak
        dom.Save sSVGPath
        
        Dim bSizeLoop As Long
        For bSizeLoop = True To False
            
            Dim lLoop As Long
            For lLoop = 0 To 3
                Dim oSvgLoop As SVGPath
                Set oSvgLoop = oUnionJack.BlueTriangle(bSizeLoop, lLoop)
                
                Dim sId As String
                sId = VBA.IIf(bSizeLoop, "Small", "Large") & "BlueTriangle" & lLoop
                

                               
                Dim xmlBlueTriangle As MSXML2.IXMLDOMElement
                Set xmlBlueTriangle = dom.createElement("svg:path")
                Call xmlBlueTriangle.setAttribute("id", sId)
                Call xmlBlueTriangle.setAttribute("style", csBLUE_STYLE)
                Call xmlBlueTriangle.setAttribute("d", oUnionJack.BlueTriangle(bSizeLoop, lLoop).D_Attribute(dScale, dTransformX, dTransformY))
                
                xmlGTranslate.appendChild xmlBlueTriangle
                xmlGTranslate.appendChild xmlLineBreak

            
            Next lLoop
            dom.Save sSVGPath
            
        
        Next bSizeLoop
        
        Dim lBlade As Long
        For lBlade = 0 To 3
            Dim oBlade As SVGPath
            Set oBlade = oUnionJack.StPatricksCrossBlade(lBlade)
            
            Dim xmlBlade As MSXML2.IXMLDOMElement
            Set xmlBlade = dom.createElement("svg:path")
            Call xmlBlade.setAttribute("id", "Blade" & lBlade)
            Call xmlBlade.setAttribute("style", csRED_STYLE)
            Call xmlBlade.setAttribute("d", oBlade.D_Attribute(dScale, dTransformX, dTransformY))
            
            xmlGTranslate.appendChild xmlBlade
        Next lBlade
        
        'dom.Save sSVGPath
        
        'dom.LoadXML StringFormatter.FormatXML(dom.xml)
        dom.Save sSVGPath
        
        
        

        'Stop
    End If


End Sub