How to Draw Arched Text
Posted on January 5, 2009
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | 'Graphics - How to Draw Arched Text Option Explicit 'Add a Picture Box to your form and set its AutoRedraw property to True. #If Win32 Then Type LOGFONT_TYPE 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 As LOGFONT_TYPE) As Long #Else Type LOGFONT_TYPE 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 #Else 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 Private Sub Form_Load() Picture1.Cls Picture1.ForeColor = vbBlue Picture1.fontname = "Courier New" Picture1.Fontsize = 12 Picture1.FontBold = True TextCircle Picture1, "http://codeitbetter.com/", 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 Else 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 |