VBA - Sheet Diagram to SVG

The VBA code below will inspect the text, hyperlinks and borders of an Excel range on a worksheet and convert to SVG (Scalable Vector Graphics) for use in an HTML context.

I wanted more diagrams on my blog and I knew I wanted to use SVG but I did not want to wrestle with an HTML artwork package such as InkScape. I felt the Excel worksheet grid is a perfectly good way to layout a diagram so Excel is my authoring tool. You can see an example of a diagram converted to SVG, below is a screenshot of the original Excel worksheet. Even further below is the source code.

Note: to get working in a blog I have had to remove the namespaces. It is nice to see hyperlinks working albeit I used javascript when then the anchor element did not render.

Option Explicit

'* Tools->References
'* Microsoft Scripting Runtime
'* Microsoft Xml v6.0
'*

Sub Test()

    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    
    Dim sSVGPath As String
    sSVGPath = "N:\InterfaceDiagram6.svg"
    
    Dim txtOut As Scripting.TextStream
    Set txtOut = fso.CreateTextFile(sSVGPath)
    txtOut.WriteLine "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""no""?>"
    txtOut.WriteLine "<svg:svg id='Simon1' xmlns:svg=""http://www.w3.org/2000/svg"" xmlns:xlink='http://www.w3.org/1999/xlink'>"
    txtOut.WriteLine "<svg:g  id='Simon2' transform='scale(2)' >"

    Dim wb As Excel.Workbook
    Set wb = ThisWorkbook 'Set wb = Workbooks(1)
    
    Dim sht1 As Excel.Worksheet
    Set sht1 = wb.Worksheets.Item("Sheet1")

    Dim vRegions As Variant
    vRegions = Array(Array(sht1.Range("b4:c13"), "Group1"), _
                    Array(sht1.Range("d2:f20"), "Group2"), _
                    Array(sht1.Range("g2:h20"), "Group3"))
                    
                    
    Test2 txtOut, vRegions


    txtOut.WriteLine "</svg:g >"
    txtOut.WriteLine "</svg:svg>"

    txtOut.Close
    Set txtOut = Nothing

    Dim dom As MSXML2.DOMDocument60
    Set dom = New MSXML2.DOMDocument60
    
    Debug.Assert dom.Load(sSVGPath)

    Debug.Assert dom.parseError = 0

End Sub


Sub Test2(txtOut, ByVal vRegions As Variant)

    Dim vRegionsLoop
    For Each vRegionsLoop In vRegions
                
        Dim rng As Excel.Range
        Set rng = vRegionsLoop(0)
        
        Dim sRegionId
        sRegionId = vRegionsLoop(1)
        
        txtOut.WriteLine "<svg:g id='" & sRegionId & "' >"
        
        Dim rngLoop As Excel.Range
        For Each rngLoop In rng.Cells
            txtOut.Write BordersToSvg(rngLoop)
            txtOut.Write TextToSvg(rngLoop)
        Next
    
        txtOut.WriteLine "</svg:g >"
    Next

End Sub


Function TextToSvg(ByVal rng As Excel.Range) As String
    Debug.Assert rng.Rows.Count = 1
    Debug.Assert rng.Columns.Count = 1

    Dim sText As String
    sText = rng.Value2

    If Len(sText) > 0 Then
    
        Dim fill As String
        fill = "fill:#000000"
    
        If rng.Hyperlinks.Count > 0 Then
            Dim lnk As Excel.Hyperlink
            Set lnk = rng.Hyperlinks.Item(1)
            
            Dim javascript As String
            javascript = " ondblclick=""window.open(&quot;" & lnk.Address & "&quot;)"" " & vbNewLine
            javascript = javascript & " onmouseover=""this.style['fill']='#ffc000';console.log(this.style['fill']);"" " & vbNewLine
            javascript = javascript & " onmouseout=""this.style['fill']='#2288bb';console.log(this.style['fill']);"" " & vbNewLine
            fill = "fill:#2288bb"
        End If
    
        Dim fnt As Excel.Font
        Set fnt = rng.Font
        
        Dim fntPx As Long
        fntPx = fnt.Size * 1 ' 4# / 3#
        
        
        Dim fntStyle As String
        fntStyle = "font-style:normal;font-weight:normal;font-size:" & fntPx & "px;line-height:1.25;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;" & fill & ";fill-opacity:1;stroke:none"
    
        Dim x
        x = rng.Left
        
        Dim y
        y = rng.Top + rng.Height
    
        Dim sId As String
        sId = VBA.Replace(rng.Address, "$", "")

        Dim s As String
        s = vbNewLine
        s = s & "<svg:text id='" & sId & "txt' x='" & x & "' y='" & y & "' style='" & fntStyle & "' " & javascript & " >" & vbNewLine
        s = s & "<svg:tspan id='" & sId & "tspan'  x='" & x + 1.25 & "' y='" & y - 2 & "' >" & sText & "</svg:tspan>" & vbNewLine
        s = s & "</svg:text>" & vbNewLine
    End If
    TextToSvg = s

End Function

Function BordersToSvg(ByVal rng As Excel.Range) As String
    Debug.Assert rng.Rows.Count = 1
    Debug.Assert rng.Columns.Count = 1
    
    Dim dicKeyedByStyle As Scripting.Dictionary
    Set dicKeyedByStyle = New Scripting.Dictionary
    
    Dim vEdges As Variant
    vEdges = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight)
    
    Dim vEdges2 As Variant
    vEdges2 = Array("xlEdgeLeft", "xlEdgeTop", "xlEdgeBottom", "xlEdgeRight")
    
    Dim lEdgeLoop As Long
    For lEdgeLoop = 7 To 10
        
        Dim brd As Excel.Border
        Set brd = rng.Borders.Item(lEdgeLoop)
        
        If Not IsNull(brd.TintAndShade) Then
            
            Dim sLine As String
            sLine = ""
            
            If lEdgeLoop = xlEdgeBottom Then
                sLine = "M " & rng.Left & "," & rng.Top + rng.Height & " L " & rng.Left + rng.Width & "," & rng.Top + rng.Height
            ElseIf lEdgeLoop = xlEdgeTop Then
                sLine = "M " & rng.Left & "," & rng.Top & " L " & rng.Left + rng.Width & "," & rng.Top
            ElseIf lEdgeLoop = xlEdgeLeft Then
                sLine = "M " & rng.Left & "," & rng.Top & " L " & rng.Left & "," & rng.Top + rng.Height
            ElseIf lEdgeLoop = xlEdgeRight Then
                sLine = "M " & rng.Left + rng.Width & "," & rng.Top & " L " & rng.Left + rng.Width & "," & rng.Top + rng.Height
            End If
            
            Dim sStyleKey As String
            sStyleKey = "stroke-width:1;stroke:#" & Right$("000000" & Hex$(brd.Color), 6) & ";" & VBA.IIf(brd.LineStyle <> 1, "stroke-miterlimit:4;stroke-dasharray:2,2;stroke-dashoffset:0", "")
            
            If dicKeyedByStyle.Exists(sStyleKey) Then
                dicKeyedByStyle(sStyleKey) = dicKeyedByStyle(sStyleKey) & " " & sLine
            Else
                dicKeyedByStyle(sStyleKey) = sLine
            End If
        End If
    Next
    
    Dim lStyleLoop As Long
    For lStyleLoop = 0 To dicKeyedByStyle.Count - 1
    
        Dim vUniqueStyle As Variant
        vUniqueStyle = dicKeyedByStyle.Keys()(lStyleLoop)
        
        Dim sId As String
        sId = "id=""" & VBA.Replace(rng.Address, "$", "") & "_" & lStyleLoop & """"
        
        Dim sStyle As String
        sStyle = " style=""" & vUniqueStyle & """ "
        
        Dim sSvgHtml As String
        sSvgHtml = "<svg:path " & sId & sStyle & " d=""" & dicKeyedByStyle(vUniqueStyle) & """/>"
    
        BordersToSvg = BordersToSvg & sSvgHtml & vbNewLine
    Next

End Function