Text on Path with VB.NET

Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Drawing.Drawing2D
Public Enum PathAlign
    Left = 0
    Center = 1
    Right = 2
End Enum
Public Enum TextPosition
    OverPath = 0
    CenterPath = 1
    UnderPath = 2
End Enum
Public Class TextOnPath
    Private _pathdataTOP As PathData
    Private _textTOP As String
    Private _fontTOP As Font
    Private _pathcolorTOP As Color = Color.Red
    Private _colorTOP As Color = Color.Black
    Private _fillcolorTOP As Color = Color.Black
    Private _pathalignTOP As PathAlign = PathAlign.Center
    Private _letterspacepercentageTOP As Integer = 100
    Private _addsvg As Boolean = False
    Private _SVG As System.Text.StringBuilder
    Private _currentPathID As Integer
    Private _textPathPosition As TextPosition = TextPosition.CenterPath
    Public LastError As Exception = Nothing
    Public ShowPath As Boolean = True
    Public Property TextPathPosition() As TextPosition
        Get
            TextPathPosition = _textPathPosition
        End Get
        Set(ByVal value As TextPosition)
            _textPathPosition = value
        End Set
    End Property
    Public Property PathDataTOP() As PathData
        Get
            PathDataTOP = _pathdataTOP
        End Get
        Set(ByVal value As PathData)
            _pathdataTOP = value
        End Set
    End Property

    Public Property TextTOP() As String
        Get
            TextTOP = _textTOP
        End Get
        Set(ByVal value As String)
            _textTOP = value
        End Set
    End Property

    Public Property FontTOP() As Font
        Get
            FontTOP = _fontTOP
        End Get
        Set(ByVal value As Font)
            _fontTOP = value
        End Set
    End Property

    Public Property PathColorTOP() As Color
        Get
            PathColorTOP = _pathcolorTOP
        End Get
        Set(ByVal value As Color)
            _pathcolorTOP = value
        End Set
    End Property
    Public Property ColorTOP() As Color
        Get
            ColorTOP = _colorTOP
        End Get
        Set(ByVal value As Color)
            _colorTOP = value
        End Set
    End Property

    Public Property FillColorTOP() As Color
        Get
            FillColorTOP = _fillcolorTOP
        End Get
        Set(ByVal value As Color)
            _fillcolorTOP = value
        End Set
    End Property

    Public Property PathAlignTOP() As PathAlign
        Get
            PathAlignTOP = _pathalignTOP
        End Get
        Set(ByVal value As PathAlign)
            _pathalignTOP = value
        End Set
    End Property

    Public Property LetterSpacePercentage() As Integer
        Get
            LetterSpacePercentage = _letterspacepercentageTOP
        End Get
        Set(ByVal value As Integer)
            _letterspacepercentageTOP = value
        End Set
    End Property
    Public Function TextOnPathBitmap(ByVal _pathdata As PathData, ByVal _text As String, ByVal _font As Font, ByVal _color As Color, ByVal _fillcolor As Color, ByVal _letterspacepercentage As Integer) As Bitmap

        _pathdataTOP = _pathdata
        _textTOP = _text
        _fontTOP = _font
        _colorTOP = _color
        _fillcolorTOP = _fillcolor
        _letterspacepercentageTOP = _letterspacepercentage
        Return TextOnPathBitmap()

    End Function
    Public Function TextOnPathBitmap() As Bitmap
        Dim i As Integer
        Dim _TmpPoints() As PointF
        Dim _TmpPoint As PointF
        Dim _Points(25000) As PointF '= oGP.PathPoints()
        Dim _count As Integer
        Dim _gp As GraphicsPath = New GraphicsPath(_pathdataTOP.Points, _pathdataTOP.Types)
        _gp.FillMode = FillMode.Winding
        _gp.Flatten(Nothing, 1)
        Try
            _TmpPoint = _gp.PathPoints(0)
            For i = 0 To _gp.PathPoints.Length - 2
                If _gp.PathTypes(i + 1) = PathPointType.Start Or (_gp.PathTypes(i) And PathPointType.CloseSubpath) = PathPointType.CloseSubpath Then
                    _TmpPoints = GetLinePoints(_gp.PathPoints(i), _TmpPoint, 1)
                    Array.ConstrainedCopy(_TmpPoints, 0, _Points, _count, _TmpPoints.Length)
                    _count += 1
                    _TmpPoint = _gp.PathPoints(i + 1)
                Else
                    _TmpPoints = GetLinePoints(_gp.PathPoints(i), _gp.PathPoints(i + 1), 1)
                    Array.ConstrainedCopy(_TmpPoints, 0, _Points, _count, _TmpPoints.Length)
                    _count += _TmpPoints.Length - 1
                End If

            Next
            ReDim _TmpPoints(_count)
            Array.Copy(_Points, _TmpPoints, _count)
            _Points = CleanPoints(_TmpPoints)

            _count = _Points.Length - 1
            Return DrawText(_Points, _count)
        Catch ex As Exception
            LastError = ex
            Return Nothing
        End Try

    End Function
    Private Function CleanPoints(ByVal _points() As PointF) As PointF()

        Dim i As Integer
        Dim _tmppoints(_points.Length) As PointF
        Dim _lastpoint As PointF
        Dim _count As Integer

        For i = 0 To _points.Length - 1
            If i = 0 Or _points(i).X <> _lastpoint.X Or _points(i).Y <> _lastpoint.Y Then
                _tmppoints(_count) = _points(i)
                _count += 1
            End If
            _lastpoint = _points(i)
        Next

        ReDim _points(_count)
        Array.Copy(_tmppoints, _points, _count)
        Return _points

    End Function

    Private Function DrawText(ByVal _Points() As PointF, ByVal _MaxPoints As Integer) As Bitmap

        Dim _gp As GraphicsPath = New GraphicsPath(_pathdataTOP.Points, _pathdataTOP.Types)
        _gp.FillMode = FillMode.Winding
        _gp.Flatten()
        Dim _bitmap As Bitmap = New Bitmap(CInt(_gp.GetBounds.Right + _fontTOP.Size * 2), CInt(_gp.GetBounds.Bottom + _fontTOP.Size * 2))
        _gp.Dispose()
        Dim _G As Graphics = Graphics.FromImage(_bitmap)
        Dim _count As Integer
        Dim _Point1 As PointF
        Dim _Point2 As PointF
        Dim _Point As PointF
        Dim _CharStep As Integer
        Dim lStrWidth As Integer
        Dim _Angle As Decimal
        Dim _MaxWidthText As Decimal
        Dim i As Integer
        Dim _widths As Single()
        '_widths = MeasureWidths(_G)
        Dim _pathpen As Pen = New Pen(_pathcolorTOP)
        If ShowPath = True Then
            For Each _Point1 In _Points
                _G.DrawEllipse(_pathpen, _Point1.X, _Point1.Y, 1, 1)
            Next
        End If
        _pathpen.Dispose()
        For i = 0 To _textTOP.Length - 1
            _MaxWidthText += StringRegion(_G, i) ' _widths(i)
        Next

        Select Case _pathalignTOP
            Case PathAlign.Left
                _Point1 = _Points(0)
                _count = 0
            Case PathAlign.Center
                _count = (_MaxPoints - _MaxWidthText) \ 2
                If _count > 0 Then
                    _Point1 = _Points(_count)
                Else
                    _Point1 = _Points(0)
                End If
            Case PathAlign.Right
                _count = (_MaxPoints - _MaxWidthText - StringRegion(_G, _textTOP.Length - 1) * LetterSpacePercentage / 100)
                If _count > 0 Then
                    _Point1 = _Points(_count)
                Else
                    _Point1 = _Points(0)
                End If
        End Select

        Do Until _CharStep > _textTOP.Length - 1
            lStrWidth = StringRegion(_G, _CharStep) * LetterSpacePercentage / 100
            If (_count + lStrWidth \ 2) >= 0 And (_count + lStrWidth) < _MaxPoints Then
                _count += lStrWidth
                _Point2 = _Points(_count)
                _Point = _Points(_count - lStrWidth \ 2)
                _Angle = GetAngle(_Point1, _Point2)
                DrawRotatedText(_G, _textTOP.Chars(_CharStep), _Angle, _Point)   '
                _Point1 = _Points(_count)
                '_G.DrawEllipse(Pens.Red, oPoint1.X, oPoint1.Y, 2, 2)
            Else
                _count += lStrWidth
            End If
            _CharStep += 1
        Loop
        _G.Dispose()
        Return _bitmap
    End Function

    Private Function StringRegion(ByVal _g As Graphics, ByVal _textpos As Integer) As Single

        Dim measureString As String = _textTOP.Substring(_textpos, 1)
        Dim numChars As Integer = measureString.Length
        Dim characterRanges(numChars) As CharacterRange
        Dim stringFormat As StringFormat = New StringFormat
        stringFormat.Trimming = StringTrimming.None
        stringFormat.FormatFlags = StringFormatFlags.NoClip Or StringFormatFlags.NoWrap Or StringFormatFlags.LineLimit
        Dim size As SizeF = _g.MeasureString(_textTOP, _fontTOP, _fontTOP.Style)
        Dim layoutRect As RectangleF = New RectangleF(0.0F, 0.0F, size.Width, size.Height)
        Dim stringRegions(numChars) As Region
        characterRanges(0) = New CharacterRange(0, 1)
        stringFormat.FormatFlags = StringFormatFlags.NoClip
        stringFormat.SetMeasurableCharacterRanges(characterRanges)
        stringFormat.Alignment = StringAlignment.Near
        stringRegions = _g.MeasureCharacterRanges(_textTOP.Substring(_textpos), _fontTOP, layoutRect, stringFormat)
        Return stringRegions(0).GetBounds(_g).Width
    End Function

    Private Function MeasureWidths(ByVal graphics As Graphics) As Single()
        Dim widths(_textTOP.Length) As Single
        Dim format As StringFormat = StringFormat.GenericTypographic
        format.Trimming = StringTrimming.None
        format.FormatFlags = StringFormatFlags.NoClip Or StringFormatFlags.NoWrap Or StringFormatFlags.LineLimit
        graphics.TextRenderingHint = Text.TextRenderingHint.AntiAlias

        Dim layout As RectangleF = New RectangleF(0, 0, 10000, 10000)
        Dim remainder As Integer = _textTOP.Length
        Dim start As Integer = 0
        While remainder > 0
            Dim length As Integer = remainder
            If length > 32 Then
                length = 32
            End If
            Dim ranges(length) As CharacterRange
            Dim i As Integer = 0
            While i < ranges.Length
                ranges(i) = New CharacterRange(start + i, 1)
                i += 1
            End While
            format.SetMeasurableCharacterRanges(ranges)
            Dim regions As Region() = graphics.MeasureCharacterRanges(_textTOP, _fontTOP, layout, format)
            i = 0
            While i < regions.Length
                Dim region As Region = regions(i)
                Dim cb As RectangleF = region.GetBounds(graphics)
                widths(start + i) = cb.Width
                i += 1
            End While
            start += length
            remainder -= 31
        End While
        Return widths
    End Function

    Private Function GetAngle(ByVal _point1 As PointF, ByVal _point2 As PointF) As Decimal
        Dim c As Decimal

        c = Math.Sqrt((_point2.X - _point1.X) ^ 2 + (_point2.Y - _point1.Y) ^ 2) 'Oh yeah good old math a�+b�=c�
        If c = 0 Then
            Return 0
        End If
        If _point1.X > _point2.X Then 'We must change the side where the triangle is
            Return Math.Asin((_point1.Y - _point2.Y) / c) * 180 / Math.PI - 180
            'Return _tangents(CInt((_point1.Y - _point2.Y) / c * 1800) + 1800) * 180 / Math.PI - 180
        Else
            Return Math.Asin((_point2.Y - _point1.Y) / c) * 180 / Math.PI
            'Return _tangents(CInt((_point2.Y - _point1.Y) / c * 1800) + 1800) * 180 / Math.PI
        End If


    End Function
    Private Sub DrawRotatedText(ByVal _gr As Graphics, ByVal _text As String, ByVal _angle As Single, ByVal _PointCenter As PointF)

        Dim string_format As New StringFormat
        string_format.Alignment = StringAlignment.Center

        _gr.SmoothingMode = SmoothingMode.HighQuality
        _gr.CompositingQuality = CompositingQuality.HighQuality
        _gr.TextRenderingHint = Text.TextRenderingHint.AntiAlias
        Dim graphics_path As New GraphicsPath(Drawing.Drawing2D.FillMode.Winding)
        Dim x As Integer = CInt(_PointCenter.X)
        Dim y As Integer = CInt(_PointCenter.Y)

        Select Case TextPathPosition
            Case TextPosition.OverPath
                graphics_path.AddString(_text, _fontTOP.FontFamily, _fontTOP.Style, _fontTOP.Size, New Point(x, y - _fontTOP.Size), string_format)
            Case TextPosition.CenterPath
                graphics_path.AddString(_text, _fontTOP.FontFamily, _fontTOP.Style, _fontTOP.Size, New Point(x, y - _fontTOP.Size \ 2), string_format)
            Case TextPosition.UnderPath
                graphics_path.AddString(_text, _fontTOP.FontFamily, _fontTOP.Style, _fontTOP.Size, New Point(x, y), string_format)
        End Select


        Dim rotation_matrix As New Matrix
        rotation_matrix.RotateAt(_angle, New PointF(x, y))
        graphics_path.Transform(rotation_matrix)

        _gr.DrawPath(New Pen(_colorTOP), graphics_path)
        _gr.FillPath(New SolidBrush(_fillcolorTOP), graphics_path)

        If _addsvg = True Then
            _SVG.Append(_createSVG(graphics_path))
        End If
        graphics_path.Dispose()
    End Sub

    Public Function GetSVG(ByVal _width As Integer, ByVal _height As Integer) As String

        Dim oXML As New System.Text.StringBuilder
        _SVG = New System.Text.StringBuilder
        _currentPathID = 1
        _addsvg = True
        TextOnPathBitmap()
        _addsvg = False

        _width = _width * 2
        _height = _height * 2
        oXML.Append("<?xml version=""1.0"" standalone=""no""?>")

        oXML.Append("<!DOCTYPE svg PUBLIC ""-//W3C//DTD SVG 20001102//EN"" ""http://www.w3.org/TR/2000/CR-SVG-20001102/DTD/svg-20001102.dtd"">" & vbCrLf)
        oXML.Append("<svg width=""" & _width & """ height=""" & _height & """ viewBox=""0 0 " & _width & " " & _height & """>" & vbCrLf)
        oXML.Append("<desc>Hello World</desc>" & vbCrLf)
        oXML.Append(_SVG.ToString)
        oXML.Append("</svg>" & vbCrLf)

        Return oXML.ToString

    End Function
    
    Private Function _createSVG(ByVal _path As GraphicsPath) As String
        Dim _pathString As New System.Text.StringBuilder
        Dim i As Integer
        Dim pt As PointF
        If _path.PathData.Points.Length = 0 Then
            Return ""
        End If
        For i = 0 To _path.PathData.Points.Length - 1
            If _path.PathData.Types(i) = PathPointType.Start Then
                _pathString.Append("M " + Str(_path.PathData.Points(i).X) + " " + Str(_path.PathData.Points(i).Y) + "" & vbCrLf)
                pt = _path.PathData.Points(i)
            End If

            If (_path.PathData.Types(i) And PathPointType.Bezier) = PathPointType.Bezier Then
                _pathString.Append(" C " + Str(_path.PathData.Points(i).X) + " " + Str(_path.PathData.Points(i).Y) _
                 + " " + Str(_path.PathData.Points(i + 1).X) + " " + Str(_path.PathData.Points(i + 1).Y) _
                 + " " + Str(_path.PathData.Points(i + 2).X) + " " + Str(_path.PathData.Points(i + 2).Y) + "" & vbCrLf)
                If (_path.PathData.Types(i + 2) And PathPointType.CloseSubpath) = PathPointType.CloseSubpath Then
                    _pathString.Append(" C " + Str(_path.PathData.Points(i + 2).X) + " " + Str(_path.PathData.Points(i + 2).Y) _
                    + " " + Str(_path.PathData.Points(i + 2).X) + " " + Str(_path.PathData.Points(i + 2).Y) _
                    + " " + Str(pt.X) + " " + Str(pt.Y) + "" & vbCrLf)
                End If
                If (_path.PathData.Types(i) And PathPointType.CloseSubpath) = PathPointType.CloseSubpath Then
                    _pathString.Append(" L " + Str(pt.X) + " " + Str(pt.Y) + "" & vbCrLf)
                End If
                i += 2
            End If

            If (_path.PathData.Types(i) And PathPointType.Line) = PathPointType.Line Then
                _pathString.Append(" L " + Str(_path.PathData.Points(i).X) + " " + Str(_path.PathData.Points(i).Y) + "" & vbCrLf)
                If (_path.PathData.Types(i) And PathPointType.CloseSubpath) = PathPointType.CloseSubpath Then
                    _pathString.Append(" L " + Str(pt.X) + " " + Str(pt.Y) + "" & vbCrLf)
                End If
            End If

        Next
        _currentPathID += 1
        Return "<path id=""" + _currentPathID.ToString + """ d=""" + _pathString.ToString + """/>" & vbCrLf
    End Function
    Public Function GetLinePoints(ByVal _p1 As PointF, ByVal _p2 As PointF, ByVal _stepWitdth As Integer) As PointF()

        Dim lCount As Integer = 0
        Dim _tmpPoints(10000) As PointF
        Dim _width As Long
        Dim _height As Long
        Dim d As Long
        Dim ix As Long
        Dim iy As Long
        Dim dd As Integer
        Dim id As Integer
        Dim lStep As Integer = _stepWitdth

        _p1.X = CInt(_p1.X)
        _p1.Y = CInt(_p1.Y)
        _p2.X = CInt(_p2.X)
        _p2.Y = CInt(_p2.Y)
        _width = _p2.X - _p1.X
        _height = _p2.Y - _p1.Y
        d = 0

        If _width < 0 Then
            _width = -_width
            ix = -1
        Else
            ix = 1
        End If

        If _height < 0 Then
            _height = -_height
            iy = -1
        Else
            iy = 1
        End If

        If _width > _height Then
            dd = _width + _width
            id = _height + _height

            Do
                If lStep = _stepWitdth Then
                    _tmpPoints(lCount).X = _p1.X
                    _tmpPoints(lCount).Y = _p1.Y
                    lCount += 1
                Else
                    lStep = lStep + _stepWitdth
                End If
                If CInt(_p1.X) = CInt(_p2.X) Then Exit Do
                _p1.X = _p1.X + ix
                d = d + id

                If d > _width Then
                    _p1.Y = _p1.Y + iy
                    d = d - dd
                End If
            Loop

        Else
            dd = _height + _height
            id = _width + _width

            Do
                If lStep = _stepWitdth Then
                    _tmpPoints(lCount).X = _p1.X
                    _tmpPoints(lCount).Y = _p1.Y
                    lCount += 1
                Else
                    lStep = lStep + _stepWitdth
                End If
                If CInt(_p1.Y) = CInt(_p2.Y) Then Exit Do
                _p1.Y = _p1.Y + iy
                d = d + id

                If d > _height Then
                    _p1.X = _p1.X + ix
                    d = d - dd
                End If
            Loop
        End If

        Dim _tmpPoints2 As PointF()
        ReDim _tmpPoints2(lCount)
        Array.Copy(_tmpPoints, _tmpPoints2, lCount)
        Return _tmpPoints2

    End Function

End Class