What's New
Q & A
Tip Jar
C# Helper...
Follow VBHelper on Twitter
MSDN Visual Basic Community
TitlePrint text that follows a curve
Keywordsprint, text, curve, rotate
The program makes a series of points that define a path. Then it calls subroutine CurveText to draw text along that path.

Subroutine CurveText uses the CreateFontIndirect API function to create a font rotated to sit along one of the segments in the path. It prints characters from teh text until no more will fit on the segment. Then it starts a new segment with its own font.

' Draw an assortment of text samples.
Private Sub cmdPrint_Click()
Const NUM_PTS = 100
Dim R As Single
Dim i As Integer
Dim ptx(1 To NUM_PTS + 1) As Single
Dim pty(1 To NUM_PTS + 1) As Single
Dim cx As Single
Dim cy As Single
Dim Rx As Single
Dim Ry As Single
Dim theta As Single
Dim dtheta As Single

    ' Make an elliptical path.
    cx = Printer.ScaleWidth / 2
    cy = Printer.ScaleHeight / 2
    Rx = cx * 0.7
    Ry = cy * 0.7
    theta = PI
    dtheta = 2 * PI / NUM_PTS
    For i = 1 To NUM_PTS + 1
        ptx(i) = cx + Rx * Cos(theta)
        pty(i) = cy + Ry * Sin(theta)
        theta = theta + dtheta
    Next i

    ' Draw the path.
    Printer.DrawWidth = 3
    Printer.Line (ptx(1), pty(1))-(ptx(2), pty(2))
    For i = 3 To NUM_PTS + 1
        Printer.Line -(ptx(i), pty(i))
    Next i

    ' Place text along the path.
    CurveText _
        "Here is some bold, italicized, Times New Roman " & _
            "text printed along a curved path. Yipee!", _
        NUM_PTS, ptx, pty, True, _
        100, 0, FW_BOLD, True, False, False, _
        PROOF_QUALITY, _
        TRUETYPE_FONTTYPE, "Times New Roman"

    MsgBox "Ok"
End Sub

' Draw a text string along a path specified by a
' series of points (ptx(i), pty(i)). The text is
' placed above the curve if parameter above is
' true. The font uses the given font metrics.
Private Sub CurveText(txt As String, numpts As Integer, _
    ptx() As Single, pty() As Single, above As Boolean, _
    nHeight As Long, nWidth As Long, fnWeight As Long, _
    fbItalic As Long, fbUnderline As Long, fbStrikeOut As _
    Long, fbCharSet As Long, fbOutputPrecision As Long, _
    fbClipPrecision As Long, fbQuality As Long, _
    fbPitchAndFamily As Long, lpszFace As String)
Dim printer_hdc As Long
Dim newfont As Long
Dim oldfont As Long
Dim theta As Single
Dim ch As String
Dim chnum As Integer
Dim needed As Single
Dim avail As Single
Dim newavail As Single
Dim pt As Integer
Dim X As Single
Dim Y As Single
Dim x1 As Single
Dim y1 As Single
Dim x2 As Single
Dim y2 As Single
Dim dx As Single
Dim dy As Single

    ' Initialize the LOGFONT structure.
    With lf
        .lfHeight = -nHeight
        .lfWidth = nWidth
        .lfWeight = fnWeight
        If fbItalic Then .lfItalic = 1
        If fbUnderline Then .lfUnderline = 1
        If fbStrikeOut Then .lfStrikeOut = 1
        .lfCharSet = fbCharSet
        .lfOutPrecision = fbOutputPrecision
        .lfClipPrecision = fbClipPrecision
        .lfQuality = fbQuality
        .lfPitchAndFamily = fbPitchAndFamily
        .lfFaceName = lpszFace & vbNullChar
    End With

    ' Set the Printer's font so we can use it's
    ' TextWidth method. (This doesn't seem to be
    ' exactly correct but is pretty close.
    ' The scaling of the size isn't quite right.)
    With Printer.Font
        .Name = lpszFace
        .Size = Printer.ScaleY(nHeight, vbPixels, vbPoints)
        .Bold = (fnWeight > FW_NORMAL)
        .Italic = fbItalic
        .Underline = fbUnderline
        .Strikethrough = fbStrikeOut
    End With

    ' Print some reference text.
    Printer.ScaleMode = vbPixels
    Printer.CurrentX = 100
    Printer.CurrentY = 100
    Printer.Print txt

    ' Initialize the printer.
    Printer.Print " "
    printer_hdc = Printer.hdc

    ' Print some comparison text.
    lf.lfEscapement = 3600
    lf.lfHeight = nHeight
    newfont = CreateFontIndirect(lf)
    oldfont = SelectObject(printer_hdc, newfont)
    TextOut printer_hdc, 100, 200, txt, Len(txt)
    SelectObject printer_hdc, oldfont
    DeleteObject newfont

    ' Get to work on the curved text.
    avail = 0
    chnum = 1

    x1 = ptx(1)
    y1 = pty(1)
    For pt = 2 To numpts
        ' See how long the new segment is.
        x2 = ptx(pt)
        y2 = pty(pt)
        dx = x2 - x1
        dy = y2 - y1
        newavail = Sqr(dx * dx + dy * dy)
        avail = avail + newavail

        ' Create a font along the segment.
        If dx > -0.1 And dx < 0.1 Then
            If dy > 0 Then
                theta = PI_OVER_2
                theta = -PI_OVER_2
            End If
            theta = Atn(dy / dx)
            If dx < 0 Then theta = theta - PI
        End If
        lf.lfEscapement = -theta * 180# / PI * 10#
        If lf.lfEscapement = 0 Then lf.lfEscapement = 3600
        newfont = CreateFontIndirect(lf)
        oldfont = SelectObject(printer_hdc, newfont)

        ' Output characters until no more fit.
            ' See how big the next character is.
            ' (Add a little to prevent characters
            ' from becoming too close together.)
            ch = Mid$(txt, chnum, 1)
            needed = Printer.TextWidth(ch) * 1.2

            ' If it's too big, get another segment.
            If needed > avail Then Exit Do

            ' See where the character belongs
            ' along the segment.
            X = x2 - dx / newavail * avail
            Y = y2 - dy / newavail * avail
            If above Then
                ' Place text above the segment.
                X = X + dy * nHeight / newavail
                Y = Y - dx * nHeight / newavail
            End If

            ' Reselect the font (using Printer.TextWidth
            ' messes it up).
            SelectObject printer_hdc, newfont

            ' Display the character.
            TextOut printer_hdc, X, Y, ch, 1

            ' Move on to the next character.
            avail = avail - needed
            chnum = chnum + 1
            If chnum > Len(txt) Then Exit Do

        ' Free the font.
        newfont = SelectObject(printer_hdc, oldfont)
        DeleteObject newfont

        If chnum > Len(txt) Then Exit For
        x1 = x2
        y1 = y2
    Next pt
End Sub

  • In older versions of Visual Basic, you could select the font and then use Printer.Print to print using it. This no longer works. You seem to have to use TextOut.
  • You must make the printer do something (such as printing a space) to initialize its HDC.
  • If you access the Printer object's properties and methods, it messes up the font. For example, if you use Printer.TextWidth to see how big the text is, the Printer reselects its default font so you will need to reselect the custom font.

For more information on advanced printing in Visual Basic, see my book Ready-to-Run Visual Basic Graphics Programming.

Copyright © 1997-2010 Rocky Mountain Computer Consulting, Inc.   All rights reserved.