' 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, _
DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, _
CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, _
PROOF_QUALITY, _
TRUETYPE_FONTTYPE, "Times New Roman"
Printer.EndDoc
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 lf As LOGFONT
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
Else
theta = -PI_OVER_2
End If
Else
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.
Do
' 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
Loop
' 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
|