SVG Text Element Width Calculator

So whilst SVG is wonderful at graphics, for text it has no word wrap features etc. this is a pain and I quickly wanted a solution to break up a paragraph of text into lines.

 This is work in progress as requirement suspended.

So the trick is to instantiate Internet Explorer and navigate to a test file with some words in it and inspect the length.  If the length is too long then you remove the last word you added.  This runs slow but it must be stressed this is dev-time process not a run-time process so no matter.

Here is the SVGTextMessageLengthCalculator class

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

'* References Microsoft Scripting Runtime
'* References Microsoft Internet Controls
'* References Microsoft HTML Object Library

Private fso As Scripting.FileSystemObject

Private moIE As InternetExplorerMedium
Private msMessage As String
Private mdCutOffLength As Double

Private msFileName As String
Private msTextStyle As String
Private msTextElementID As String
Private mx As Double
Private my As Double

Public Sub Initialise(ByVal sMessage As String, ByVal sFileName As String, _
                    ByVal sTextStyle As String, ByVal sTextElementID As String, ByVal x As Double, ByVal y As Double, _
                    ByVal dCutOffLength As Double)
    'these are parameters unchanging whilst the text message remains constant so stash in class members
    msFileName = sFileName
    msTextStyle = sTextStyle
    msTextElementID = sTextElementID
    mx = x
    my = y
    
    msMessage = sMessage
    mdCutOffLength = dCutOffLength
                    
    Set moIE = New InternetExplorerMedium
    moIE.Visible = True
                    
End Sub


Public Function CalculateChunks() As Scripting.Dictionary
    Dim dicChunks As New Scripting.Dictionary '* used as expanding array/vector
    Dim sRemainder As String, sChunk As String
    
    sRemainder = CycleThroughTextMessage(msMessage, mdCutOffLength, sChunk)
    dicChunks.Add dicChunks.Count, sChunk
    While Len(sRemainder) > 0
    
        sRemainder = CycleThroughTextMessage(sRemainder, mdCutOffLength, sChunk)
        dicChunks.Add dicChunks.Count, sChunk
    Wend
    
    Set CalculateChunks = dicChunks

End Function

Private Function CycleThroughTextMessage( _
            ByVal sTextMessage As String, ByVal dCutOffLength As Double, _
            ByRef psChunk As String) As String


    Dim vSplitTextMessage As Variant
    vSplitTextMessage = VBA.Split(sTextMessage)

    Dim sTextAccumulator As String
    Dim sSavedTextAccumulator As String
    
    Dim vSplitLoop As Variant
    For Each vSplitLoop In vSplitTextMessage
        sTextAccumulator = sTextAccumulator & vSplitLoop & " "
        
        WriteSVGTextFile sTextAccumulator
        
        Dim dLength As Double
        dLength = NavigateToTextMessageAndMeasureWidth
        If dLength > dCutOffLength Then
            Dim sRemainder As String
            sRemainder = Mid(sTextMessage, Len(sSavedTextAccumulator) + 1)
            Debug.Assert Len(sRemainder) + Len(sSavedTextAccumulator) - Len(sTextMessage) = 0
            Exit For
        End If
        sSavedTextAccumulator = sTextAccumulator
    Next vSplitLoop
    psChunk = sSavedTextAccumulator
    CycleThroughTextMessage = sRemainder


End Function

Public Sub Terminate()
    Set fso = Nothing
    moIE.Quit
    Set moIE = Nothing
End Sub

Private Function NavigateToTextMessageAndMeasureWidth() As Double
    Debug.Assert Not moIE Is Nothing
    moIE.navigate msFileName '"N:\drawing.svg"
    While moIE.Busy = True
        DoEvents
    Wend

    Dim doc As HTMLDocument
    Set doc = moIE.document

    Dim objTextElement As MSHTML.SVGTSpanElement
    Set objTextElement = doc.getElementById(msTextElementID)

    NavigateToTextMessageAndMeasureWidth = objTextElement.getComputedTextLength

End Function


Private Sub WriteSVGTextFile(ByVal sTextMessage As String)
    Debug.Assert Not fso Is Nothing
    
    Dim txt As Scripting.TextStream
    Set txt = fso.CreateTextFile(msFileName)
    
    txt.WriteLine Chr$(60) & "?xml version=""1.0"" encoding=""UTF-8"" standalone=""no""?" & Chr$(62)
    txt.WriteLine Chr$(60) & "svg xmlns=""http://www.w3.org/2000/svg"" width=""210mm"" height=""297mm"" viewBox=""0 0 744.09448819 1052.3622047"" id=""svg2"" version=""1.1"" " & Chr$(62)
    txt.WriteLine Chr$(60) & "text "
    txt.WriteLine "xml:space=""preserve"" "
    txt.WriteLine "style=""" & msTextStyle & """ "
    txt.WriteLine "id=""" & msTextElementID & """ "
    txt.WriteLine "x=""" & CStr(mx) & """ "
    txt.WriteLine "y=""" & CStr(my) & """" & Chr$(62)
    txt.WriteLine sTextMessage
    txt.WriteLine Chr$(60) & "/text>"
    txt.WriteLine Chr$(60) & "/svg" & Chr$(62)
    txt.Close
    
    
    
End Sub

Private Sub Class_Initialize()
    Set fso = New Scripting.FileSystemObject
End Sub

And here is some test calling code

Attribute VB_Name = "tstSVGTextMessageLengthCal"
Option Explicit

Sub Test()
    Dim sMessage As String
    sMessage = "The financial markets have begun to wake up to the fact that the Republican reforms " & _
                "to US corporate taxation will probably include important new 'border adjustments' to " & _
                "the definitions of company revenues and costs. The basic idea is that US should shift " & _
                "to a 'territorial' system, with corporations being taxed only on revenues and costs " & _
                "incurred within the US itself, and not on their worldwide aggregates, which is the " & _
                "principle behind the present system. [1]"


    Dim oTextMessageLengthCalculator As SVGTextMessageLengthCalculator
    Set oTextMessageLengthCalculator = New SVGTextMessageLengthCalculator
    Const sFileName As String = "N:\drawing2.svg"
    Const sSTYLE As String = "font-style:normal;font-weight:normal;font-size:40px;line-height:125%;font-family:sans-serif;letter-spacing:0px;word-spacing:0px;fill:#000000;fill-opacity:1;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1"
    Const sTEXTELEMENT_ID As String = "id001"
    oTextMessageLengthCalculator.Initialise sMessage, sFileName, sSTYLE, sTEXTELEMENT_ID, 20, 50, 700


    
    Dim dicChunks As New Scripting.Dictionary '* used as expanding array/vector
    Set dicChunks = oTextMessageLengthCalculator.CalculateChunks
    oTextMessageLengthCalculator.Terminate
    
    Debug.Print VBA.Join(dicChunks.Items, vbNewLine)

End Sub