Text within a curved line - Visual Basic , VB.NET

	Find Code:
Home : Code : Forums : Submit : Mailing List : About : Contact

All

VB.NET

ASP.NET

C#

Snippets

Popular

Forums

Articles

Tips

Links

Books

Contest

Text within a curved line
Author: Dante Souto
Submitted: 9/20/2014
Version: VB 2012
Compatibility: VB 2010, VB 2012, VB 2013
Category: Graphics
Views: 5959
Demonstrates the technique of placing a text inside a line with multiple curves.
Declarations:
Imports System.Drawing.Graphics Imports System.Drawing.Drawing2D
Code:
Public Class Form1 Private Sub Form1_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles Me.Paint Dim ts As New TextStrokeObject() Dim pt() As PointF = {New PointF(40, 40), New PointF(80, 80), New PointF(105, 80), New PointF(130, 110), New PointF(160, 120), New PointF(230, 160), New PointF(255, 160), New PointF(280, 180), New PointF(280, 190)} ts.GraphicsObject = e.Graphics ts.CompositingQuality = Drawing2D.CompositingQuality.HighQuality ts.SmoothingMode = Drawing2D.SmoothingMode.AntiAlias ts.SourcePoints = pt ts.Text = "dantesouto@gmail.com" ts.StrokeWidth = 10 ts.StrokeColor = Color.Blue ts.TextColor = Color.White ts.Iniciar() End Sub End Class Public Class TextStrokeObject Private def_MinFontSize As Single = 5' determina o tamanho mínimo da fonte Private def_TextMargin As Single = 15' determina as margens a esquerda e direita do texto Private mApplyText As Boolean = True Private mTextSize As Double Private mLineSize() As Single' o tamanho de cada segmento Private mCharSize() As SizeF Private mFontHeight As Single #Region "Propertys" Private mText As String Private mTextColor As Color = Color.Black Private mTextLineWidth As Single = 1 Private mSourcePoints() As PointF Private mPoints() As PointF Private mRoundCorners As Boolean = True Private mRoundSize As Integer = 5 Private mBitmapObject As Bitmap Private mGraphicsObject As Graphics Private mSmoothingMode As SmoothingMode = Drawing2D.SmoothingMode.Default Private mTextRenderingHint As Text.TextRenderingHint = Drawing.Text.TextRenderingHint.SystemDefault Private mCompositingQuality As CompositingQuality = Drawing2D.CompositingQuality.Default Private mStrokeFontFamily As FontFamily = New FontFamily("Verdana") Private mStrokeFontStyle As FontStyle = FontStyle.Regular Private mStrokeColor As Color Private mFontSize As Single = 16.0F Private mStrokeWidth As Single = 5 Private mStrokeLength As Double = 0 Public Property Text() As String Get Return mText End Get Set(ByVal value As String) mText = value End Set End Property Public Property TextColor() As Color Get Return mTextColor End Get Set(ByVal value As Color) mTextColor = value End Set End Property Public Property TextLineWidth() As Single Get Return mTextLineWidth End Get Set(ByVal value As Single) mTextLineWidth = value End Set End Property Public Property SourcePoints() As PointF() Get Return mSourcePoints End Get Set(ByVal value() As PointF) mSourcePoints = value End Set End Property Public ReadOnly Property Points() As PointF() Get Return mPoints End Get End Property Public Property RoundCorners() As Boolean Get Return mRoundCorners End Get Set(ByVal value As Boolean) mRoundCorners = value End Set End Property Public Property RoundSize() As Integer Get Return mRoundSize End Get Set(ByVal value As Integer) mRoundSize = value End Set End Property Public Property SmoothingMode() As SmoothingMode Get Return mSmoothingMode End Get Set(ByVal value As SmoothingMode) mSmoothingMode = value End Set End Property Public Property TextRenderingHint() As Text.TextRenderingHint Get Return mTextRenderingHint End Get Set(ByVal value As Text.TextRenderingHint) mTextRenderingHint = value End Set End Property Public Property CompositingQuality() As CompositingQuality Get Return mCompositingQuality End Get Set(ByVal value As CompositingQuality) mCompositingQuality = value End Set End Property Public Property BitmapObject() As Bitmap Get Return mBitmapObject End Get Set(ByVal value As Bitmap) mBitmapObject = value End Set End Property Public Property GraphicsObject() As Graphics Get Return mGraphicsObject End Get Set(ByVal value As Graphics) mGraphicsObject = value End Set End Property Public Property StrokeFontFamily() As FontFamily Get Return mStrokeFontFamily End Get Set(ByVal value As FontFamily) mStrokeFontFamily = value End Set End Property Public Property StrokeFontStyle() As FontStyle Get Return mStrokeFontStyle End Get Set(ByVal value As FontStyle) mStrokeFontStyle = value End Set End Property Public ReadOnly Property FontSize() As Single Get Return mFontSize End Get End Property Public Property StrokeWidth() As Single Get Return mStrokeWidth End Get Set(ByVal value As Single) mStrokeWidth = value End Set End Property Public ReadOnly Property StrokeLength() As Double Get Return mStrokeLength End Get End Property Public Property StrokeColor() As Color Get Return mStrokeColor End Get Set(ByVal value As Color) mStrokeColor = value End Set End Property #End Region #Region "Private Functions" Private Sub SetStrokeLength() ' ' Qual o comprimento da linha ' Dim soma As Double = 0 Dim dx As Double Dim dy As Double Dim i As Long ReDim mLineSize(mPoints.Length - 1) mLineSize(0) = 0 For i = 1 To mPoints.Length - 1 dx = mPoints(i).X - mPoints(i - 1).X dy = mPoints(i).Y - mPoints(i - 1).Y mLineSize(i) = Math.Sqrt(dx * dx + dy * dy) soma = soma + mLineSize(i) Next mStrokeLength = soma End Sub Private Sub SetTextSize() ' ' Determina o comprimento do texto e o tamanho da fonte ' Dim avanco As Double = 0 Dim ch As Long Dim chSz As SizeF Dim fnt As Font = New Font(mStrokeFontFamily, mFontSize, mStrokeFontStyle, GraphicsUnit.Pixel) mApplytext = True If mText = "" Then mApplytext = False Else Do Dim tmpFont As New Font(mStrokeFontFamily, mFontSize, mStrokeFontStyle, GraphicsUnit.Pixel) mFontHeight = mGraphicsObject.MeasureString(mText, tmpFont, New PointF(0, 0), StringFormat.GenericDefault).Height If mFontHeight < mStrokeWidth Then fnt = tmpFont Exit Do End If mFontSize = mFontSize - 0.2 If mFontSize <= def_MinFontSize Then ' atingiu o tamanho mínimo cancela a aplicação do texto mApplytext = False Exit Do End If Loop If mApplytext = True Then ReDim mCharSize(mText.Length - 1) ' determinando o comprimento do texto For ch = 0 To mText.Length - 1 chSz = mGraphicsObject.MeasureString(mText.Substring(ch, 1), fnt) mCharSize(ch) = chSz avanco = avanco + chSz.Width Next mTextSize = avanco If (def_TextMargin * 2) + mTextSize > mStrokeLength Then ' o texto tem que caber dentro da linha, incluindo as margens mApplytext = False End If End If End If End Sub Private Sub ApplyText() If mApplyText = True Then Dim stPos As Single Dim fator As Integer = CInt(mStrokeLength / ((def_TextMargin * 2) + mTextSize)) If fator > 3 Then ' vai repetir stPos = def_TextMargin InsertTextAt(stPos) Else ' vai centralizar ' onde inicia stPos = (mStrokeLength / 2) - (mTextSize / 2) InsertTextAt(stPos) End If End If End Sub Private Sub InsertTextAt(ByVal startPos As Double) Dim I As Long = 0 Dim stPos As Double = startPos Dim comprimento As Double = 0 Dim ch As Integer' posição do caracter Dim rotation_matrix As New Drawing2D.Matrix() Dim ha As Single Dim Seno As Single Dim pt As PointF Dim angle As Single Dim dy As Single Dim dx As Single For I = 1 To mPoints.Length - 1 comprimento = comprimento + mLineSize(I) If stPos <= comprimento Then ' definindo o angulo desta reta dx = mPoints(I).X - mPoints(I - 1).X dy = mPoints(I).Y - mPoints(I - 1).Y angle = Math.Atan2(dy, dx) * 180 / Math.PI ' definindo a posição do ponto Seno = dy / mLineSize(I) Do Until stPos > comprimento ha = mLineSize(I) - (comprimento - stPos) pt.Y = (ha * Seno) + mPoints(I - 1).Y pt.X = (Math.Sqrt((ha ^ 2) - ((ha * Seno) ^ 2))) + mPoints(I - 1).X rotation_matrix.Reset() rotation_matrix.RotateAt(angle, pt) pt.X = pt.X - (mCharSize(ch).Width * 0.5F) pt.Y = pt.Y - (mCharSize(ch).Height * 0.5F) Dim chPath As New GraphicsPath chPath.AddString(mText.Substring(ch, 1), mStrokeFontFamily, mStrokeFontStyle, mFontSize, pt, StringFormat.GenericDefault) chPath.Transform(rotation_matrix) mGraphicsObject.DrawPath(New Pen(mTextColor, mTextLineWidth), chPath) stPos = stPos + mCharSize(ch).Width ch = ch + 1 If ch = mText.Length Then Exit For End If Loop End If Next End Sub #End Region #Region "RoundCorners" Private Function DrawBezier2(ByVal pf() As PointF) As PointF() Dim i As Long Dim t As Long = 0 Dim dx As Single Dim dy As Single Dim h As Single Dim rad As Single Dim angle As Single Dim Seno As Single Dim ha As Single Dim pt(((pf.Length - 1) * 3) - 2) As PointF Dim pb() As PointF Dim pfRet() As PointF Dim b As Long Dim r As Long = 0 pt(0) = pf(0) ReDim pfRet(0) pfRet(r) = pf(0) For i = 1 To pf.Length - 2 ReDim pb(2) dx = pf(i).X - pf(i - 1).X dy = pf(i).Y - pf(i - 1).Y h = Math.Sqrt(dx * dx + dy * dy) If h > CSng(mRoundSize) * 2 Then rad = Math.Atan2(dy, dx) angle = rad * 180 / Math.PI Seno = dy / h ha = h - CSng(mRoundSize) t = t + 1 pt(t).Y = (ha * Seno) + pf(i - 1).Y pt(t).X = (Math.Sqrt((ha ^ 2) - ((ha * Seno) ^ 2))) + pf(i - 1).X pb(0) = pt(t) t = t + 1 pt(t) = pf(i) pb(1) = pt(t) dx = pf(i + 1).X - pf(i).X dy = pf(i + 1).Y - pf(i).Y h = Math.Sqrt(dx * dx + dy * dy) rad = Math.Atan2(dy, dx) angle = rad * 180 / Math.PI Seno = dy / h ha = CSng(mRoundSize) t = t + 1 pt(t).Y = (ha * Seno) + pf(i).Y pt(t).X = (Math.Sqrt((ha ^ 2) - ((ha * Seno) ^ 2))) + pf(i).X pb(2) = pt(t) pb = DrawBezier(pb) ReDim Preserve pfRet(pfRet.Length + pb.Length - 1) For b = 0 To pb.Length - 1 r = r + 1 pfRet(r) = pb(b) Next End If Next t = t + 1 pt(t) = pf(i) ReDim Preserve pfRet(pfRet.Length) r = r + 1 pfRet(r) = pf(i) Return pfRet End Function Private Function DrawBezier(ByVal pt() As PointF) As PointF() 'http://www.planetsourcecode.com/vb/scripts/ShowCode.asp?txtCodeId=74671&lngWId=1 Dim definicao As Single = 0.1F Dim tDef As Long Dim ptRet() As PointF Dim X As Single Dim Y As Single Dim u As Single Dim k As Long Dim n As Long Dim bv As Single Do tDef = CLng(1 / definicao) If tDef >= 10 * pt.Length Then Exit Do End If definicao = definicao / 10 Loop ReDim ptRet(tDef) n = pt.Length - 1 For u = 0 To 1 Step definicao X = 0 Y = 0 For k = 0 To n bv = Bezialize(k, n, u) X = X + pt(k).X * bv Y = Y + pt(k).Y * bv Next k ptRet(u * tDef).X = X ptRet(u * tDef).Y = Y Next Return ptRet End Function Private Function Bezialize(ByVal k As Single, ByVal n As Single, ByVal u As Single) As Single Return Cabeze(n, k) * (u ^ k) * (1 - u) ^ (n - k) End Function Private Function Cabeze(ByVal n As Single, ByVal r As Single) As Single Return factCabeze(n) / (factCabeze(r) * factCabeze(n - r)) End Function Private Function factCabeze(ByVal n As Single) As Single If n = 1 Or n = 0 Then Return 1 Else Return n * factCabeze(n - 1) End If End Function Private Sub DrawLine() Dim I As Integer For I = 1 To mPoints.Length - 1 mGraphicsObject.DrawLines(New Pen(mStrokeColor, mStrokeWidth), mPoints) Next End Sub #End Region Public Sub New() mBitmapObject = New Bitmap(256, 256) mGraphicsObject = Graphics.FromImage(mBitmapObject) End Sub Public Sub New(ByVal bm As Bitmap) mBitmapObject = bm mGraphicsObject = Graphics.FromImage(mBitmapObject) End Sub Public Sub New(ByRef e As Graphics) mGraphicsObject = e End Sub Public Sub New(ByVal pt() As PointF, ByVal strToDo As String, ByVal e As Graphics) mGraphicsObject = e mSourcePoints = pt mText = strToDo Me.Iniciar() End Sub Public Sub Iniciar() mGraphicsObject.SmoothingMode = mSmoothingMode mGraphicsObject.TextRenderingHint = mTextRenderingHint mGraphicsObject.CompositingQuality = mCompositingQuality If mRoundCorners = True Then mPoints = DrawBezier2(mSourcePoints) Else mPoints = mSourcePoints End If 'draw points DrawLine() ' chamando as rotinas de cálculo SetStrokeLength() SetTextSize() ApplyText() End Sub End Class