Draw Arched Text

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Picture Box to your form. Set The Picture Box AutoRedraw property to True.
'Insert the following code to your module:

#If Win32 Then
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lffacename As String * 32
End Type
Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont _
lfHeight As Integer
lfWidth As Integer
lfEscapement As Integer
lfOrientation As Integer
lfWeight As Integer
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lffacename As String * 32
End Type
Declare Function CreateFontIndirect Lib "GDI" (lpLogFont As Any) As Integer
#End If
#If Win32 Then
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject _
As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function SelectObject Lib "GDI" (ByVal hdc As Integer, ByVal hObject _
As Integer) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
#End If

'Insert the following code to your form:

Private Sub Form_Load()
'Replace 'vbBlue' with the text color.
Picture1.ForeColor = vbBlue
'Enter here font properties: Font name, size Etc.
Picture1.fontname = "arial"
Picture1.Fontsize = 12
Picture1.FontBold = True
'Replace 'Visual Basic' with your own text, 'Picture1.ScaleWidth / 2' with
'the X Coordinate of the text, 'Picture1.ScaleHeight' with the Y Coordinate
'of the text, 'Picture1.ScaleHeight * 0.8' with the radius of the arc, '-1' with
'th starting degree.

TextCircle Picture1, "Visual Basic", Picture1.ScaleWidth / 2, _
Picture1.ScaleHeight, Picture1.ScaleHeight * 0.8, -1
End Sub

Public Sub TextCircle(obj As Object, txt As String, X As Long, Y As Long, _
radius As Long, startdegree As Double)
Dim foo As Integer, TxtX As Long, TxtY As Long, checkit As Integer
Dim twipsperdegree As Long, wrktxt As String, wrklet As String, _
degreexy As Double, degree As Double
twipsperdegree = (radius * 3.14159 * 2) / 360
If startdegree < 0 Then
Select Case startdegree
Case -1
startdegree = Int(360 - (((obj.TextWidth(txt)) / twipsperdegree) / 2))
Case -2
radius = (obj.TextWidth(txt) / 2) / 3.14159
twipsperdegree = (radius * 3.14159 * 2) / 360
End Select
End If
For foo = 1 To Len(txt)
wrklet = Mid$(txt, foo, 1)
degreexy = (obj.TextWidth(wrktxt)) / twipsperdegree + startdegree
DegreesToXY X, Y, degreexy, radius, radius, TxtX, TxtY
degree = (obj.TextWidth(wrktxt) + 0.5 * obj.TextWidth(wrklet)) / _
twipsperdegree + startdegree
RotateText 360 - degree, obj, obj.fontname, obj.Fontsize, (TxtX), (TxtY), wrklet
wrktxt = wrktxt & wrklet
Next foo
End Sub

Public Sub DegreesToXY(CenterX As Long, CenterY As Long, degree As Double, _
radiusX As Long, radiusY As Long, X As Long, Y As Long)
Dim convert As Double
convert = 3.141593 / 180
X = CenterX - (Sin(-degree * convert) * radiusX)
Y = CenterY - (Sin((90 + (degree)) * convert) * radiusY)
End Sub

Public Sub RotateText(Degrees As Integer, obj As Object, fontname As String, _
Fontsize As Single, X As Integer, Y As Integer, Caption As String)
Dim RotateFont As LOGFONT_TYPE
Dim CurFont As Integer, rFont As Integer, foo As Integer
RotateFont.lfEscapement = Degrees * 10
RotateFont.lffacename = fontname & Chr$(0)
If obj.FontBold Then
RotateFont.lfWeight = 800
RotateFont.lfWeight = 400
End If
RotateFont.lfHeight = (Fontsize * -20) / Screen.TwipsPerPixelY
rFont = CreateFontIndirect(RotateFont)
CurFont = SelectObject(obj.hdc, rFont)
obj.CurrentX = X
obj.CurrentY = Y
obj.Print Caption
foo = SelectObject(obj.hdc, CurFont)
foo = DeleteObject(rFont)
End Sub

Go Back