Imports System.Drawing.Drawing2D

Imports System.Drawing.Text

Public Class Form1

  Private Sub Form1_Paint(sender As Object, e As PaintEventArgs) Handles Me.Paint

　　e.Graphics.TextRenderingHint = TextRenderingHint.AntiAlias

　　e.Graphics.SmoothingMode = SmoothingMode.HighQuality

　　e.Graphics.PixelOffsetMode = PixelOffsetMode.HighQuality



    Using linePen As New Pen(Color.FromArgb(128, Color.Red), 5)

      Dim lineText = "サンプル文字列 sample string"



      Dim line = (New PointF(20, 20), New PointF(200, 200))

　　　e.Graphics.DrawString(lineText, Me.Font, Brushes.Lime, 0, line.Item1, line.Item2, False)

　　　e.Graphics.DrawString(lineText, Me.Font, Brushes.Blue, 0, line.Item1, line.Item2, True)

　　　e.Graphics.DrawLine(linePen, line.Item1, line.Item2)



      Using gPath As New GraphicsPath()

　　　　gPath.StartFigure()

　　　　gPath.AddArc(New Rectangle(150, 20, 150, 150), 180, 180)



　　　　e.Graphics.DrawString(lineText, Me.Font, Brushes.Lime, gPath, False)

　　　　e.Graphics.DrawString(lineText, Me.Font, Brushes.Blue, gPath, True)

　　　　e.Graphics.DrawPath(linePen, gPath)

      End Using

    End Using

  End Sub

End Class



Public Module GraphicsExtensions

　<System.Runtime.CompilerServices.Extension()> _

  Public Function MeasureStringWithSpace(g As Graphics, txt As String, f As Font) As SizeF

    Dim sz = g.MeasureString(txt, f, PointF.Empty, StringFormat.GenericTypographic)

　　sz.Width += f.Size * (txt.Length - txt.Trim().Length)

    Return sz

  End Function



　<System.Runtime.CompilerServices.Extension>

  Public Sub DrawString(g As Graphics, txt As String, f As Font, b As Brush, _

        path As GraphicsPath, above As Boolean)

    Dim p = DirectCast(path.Clone(), GraphicsPath)

　　p.Flatten()

    Dim pos As (i As Integer, p As PointF) = (0, p.PathPoints(0))

    For iTo = 1 To p.PointCount - 1

　　　pos = g.DrawString(txt, f, b, pos.i, pos.p, p.PathPoints(iTo), above)

      If pos.i >= txt.Length Then

        Return

      End If

    Next

  End Sub



　<System.Runtime.CompilerServices.Extension()> _

  Public Function DrawString(g As Graphics, txt As String, f As Font, b As Brush, _

        iFrom As Integer, pFrom As PointF, pTo As PointF, above As Boolean _

        ) As (iNext As Integer, pNext As PointF)

    Dim state = g.Save()



　　'補正距離 

    Dim dx = CDbl(pTo.X - pFrom.X)

    Dim dy = CDbl(pTo.Y - pFrom.Y)

    Dim distance = (dx * dx + dy * dy) ^ 0.5

　　dx /= distance

　　dy /= distance



　　'文字列の切り出し 

    Dim iTo = iFrom

    Dim iLength = txt.Length

    Do Until iTo >= iLength

      Dim measure = txt.Substring(iFrom, iTo - iFrom + 1)

      If CSng(g.MeasureStringWithSpace(measure, f).Width) > distance Then

　　　　iTo -= 1

        Exit Do

      Else

　　　　iTo += 1

      End If

    Loop

    If iTo < iFrom Then

      Return (iFrom, pFrom)

    ElseIf iLength <= iTo Then

　　　iTo = iLength - 1

    End If

    Dim outText = txt.Substring(iFrom, iTo - iFrom + 1)

    Dim outSize = g.MeasureStringWithSpace(outText, f)



　　'回転と移動 

    If above Then

　　　'文字の高さ分だけ上方向にずらす 

　　　g.TranslateTransform(0, -outSize.Height, MatrixOrder.Append)

    End If

　　g.RotateTransform(CSng(180.0 * Math.Atan2(dy, dx) / Math.PI), MatrixOrder.Append)

　　g.TranslateTransform(pFrom.X, pFrom.Y, MatrixOrder.Append)



　　'文字列描画 

　　g.DrawString(outText, f, b, PointF.Empty)



　　g.Restore(state)



　　'次の描画位置 

    Return (iTo + 1, New PointF( _

      CSng(pFrom.X + dx * outSize.Width), _

      CSng(pFrom.Y + dy * outSize.Width)))

  End Function

End Module