home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Graphics Programming (2nd Edition) / Visual Basic Graphics Programming 2nd Edition.iso / Src / Ch4 / Spiral.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1999-04-02  |  7.3 KB  |  196 lines
  1. VERSION 5.00
  2. Begin VB.Form frmSpiral 
  3.    AutoRedraw      =   -1  'True
  4.    Caption         =   "Spiral"
  5.    ClientHeight    =   5325
  6.    ClientLeft      =   1815
  7.    ClientTop       =   870
  8.    ClientWidth     =   5715
  9.    LinkTopic       =   "Form1"
  10.    PaletteMode     =   1  'UseZOrder
  11.    ScaleHeight     =   266.25
  12.    ScaleMode       =   2  'Point
  13.    ScaleWidth      =   285.75
  14. Attribute VB_Name = "frmSpiral"
  15. Attribute VB_GlobalNameSpace = False
  16. Attribute VB_Creatable = False
  17. Attribute VB_PredeclaredId = True
  18. Attribute VB_Exposed = False
  19. Option Explicit
  20. Private Const PI = 3.14159
  21. Private Const PI_OVER_2 = PI / 2
  22. ' Font weight constants.
  23. Private Const FW_DONTCARE = 0
  24. Private Const FW_THIN = 100
  25. Private Const FW_EXTRALIGHT = 200
  26. Private Const FW_LIGHT = 300
  27. Private Const FW_NORMAL = 400
  28. Private Const FW_MEDIUM = 500
  29. Private Const FW_SEMIBOLD = 600
  30. Private Const FW_BOLD = 700
  31. Private Const FW_EXTRABOLD = 800
  32. Private Const FW_HEAVY = 900
  33. Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
  34. Private Const FW_REGULAR = FW_NORMAL
  35. Private Const FW_DEMIBOLD = FW_SEMIBOLD
  36. Private Const FW_ULTRABOLD = FW_EXTRABOLD
  37. Private Const FW_BLACK = FW_HEAVY
  38. ' Character set constants.
  39. Private Const ANSI_CHARSET = 0
  40. Private Const DEFAULT_CHARSET = 1
  41. Private Const SYMBOL_CHARSET = 2
  42. Private Const SHIFTJIS_CHARSET = 128
  43. Private Const OEM_CHARSET = 255
  44. ' Output precision constants.
  45. Private Const OUT_CHARACTER_PRECIS = 2
  46. Private Const OUT_DEFAULT_PRECIS = 0
  47. Private Const OUT_DEVICE_PRECIS = 5
  48. Private Const OUT_RASTER_PRECIS = 6
  49. Private Const OUT_STRING_PRECIS = 1
  50. Private Const OUT_STROKE_PRECIS = 3
  51. Private Const OUT_TT_ONLY_PRECIS = 7
  52. Private Const OUT_TT_PRECIS = 4
  53. ' Clipping precision constants.
  54. Private Const CLIP_CHARACTER_PRECIS = 1
  55. Private Const CLIP_DEFAULT_PRECIS = 0
  56. Private Const CLIP_EMBEDDED = &H80
  57. Private Const CLIP_LH_ANGLES = &H10
  58. Private Const CLIP_STROKE_PRECIS = 2
  59. Private Const CLIP_TO_PATH = 4097
  60. Private Const CLIP_TT_ALWAYS = &H20
  61. ' Character quality constants.
  62. Private Const DEFAULT_QUALITY = 0
  63. Private Const DRAFT_QUALITY = 1
  64. Private Const PROOF_QUALITY = 2
  65. ' Pitch and family constants.
  66. Private Const DEFAULT_PITCH = 0
  67. Private Const FIXED_PITCH = 1
  68. Private Const VARIABLE_PITCH = 2
  69. Private Const TRUETYPE_FONTTYPE = &H4
  70. Private Const FF_DECORATIVE = 80  '  Old English, etc.
  71. Private Const FF_DONTCARE = 0     '  Don't care or don't know.
  72. Private Const FF_MODERN = 48      '  Constant stroke width, serifed or sans-serifed.
  73. Private Const FF_ROMAN = 16       '  Variable stroke width, serifed.
  74. Private Const FF_SCRIPT = 64      '  Cursive, etc.
  75. Private Const FF_SWISS = 32       '  Variable stroke width, sans-serifed.
  76. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  77. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  78. Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W2 As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
  79. ' Draw a text string along a path specified by a
  80. ' series of points (ptx(i), pty(i)). The text is
  81. ' placed above the curve if parameter above is
  82. ' true. The font uses the given font metrics.
  83. 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)
  84. Dim newfont As Long
  85. Dim oldfont As Long
  86. Dim theta As Single
  87. Dim escapement As Long
  88. Dim ch As String
  89. Dim chnum As Integer
  90. Dim needed As Single
  91. Dim avail As Single
  92. Dim newavail As Single
  93. Dim pt As Integer
  94. Dim x1 As Single
  95. Dim y1 As Single
  96. Dim x2 As Single
  97. Dim y2 As Single
  98. Dim dx As Single
  99. Dim dy As Single
  100.     avail = 0
  101.     chnum = 1
  102.     x1 = ptx(1)
  103.     y1 = pty(1)
  104.     For pt = 2 To numpts
  105.         ' See how long the new segment is.
  106.         x2 = ptx(pt)
  107.         y2 = pty(pt)
  108.         dx = x2 - x1
  109.         dy = y2 - y1
  110.         newavail = Sqr(dx * dx + dy * dy)
  111.         avail = avail + newavail
  112.         
  113.         ' Create a font along the segment.
  114.         If dx > -0.1 And dx < 0.1 Then
  115.             If dy > 0 Then
  116.                 theta = PI_OVER_2
  117.             Else
  118.                 theta = -PI_OVER_2
  119.             End If
  120.         Else
  121.             theta = Atn(dy / dx)
  122.             If dx < 0 Then theta = theta - PI
  123.         End If
  124.         escapement = -theta * 180# / PI * 10#
  125.         If escapement = 0 Then escapement = 3600
  126.         newfont = CreateFont(nHeight, nWidth, escapement, 0, fnWeight, fbItalic, fbUnderline, fbStrikeOut, fbCharSet, fbOutputPrecision, fbClipPrecision, fbQuality, fbPitchAndFamily, lpszFace)
  127.         oldfont = SelectObject(hdc, newfont)
  128.         ' Output characters until no more fit.
  129.         Do
  130.             ' See how big the next character is.
  131.             ' (Add a little to prevent characters
  132.             ' from becoming too close together.)
  133.             ch = Mid$(txt, chnum, 1)
  134.             needed = TextWidth(ch) * 1.2
  135.             
  136.             ' If it's too big, get another segment.
  137.             If needed > avail Then Exit Do
  138.             
  139.             ' See where the character belongs
  140.             ' along the segment.
  141.             CurrentX = x2 - dx / newavail * avail
  142.             CurrentY = y2 - dy / newavail * avail
  143.             If above Then
  144.                 ' Place text above the segment.
  145.                 CurrentX = CurrentX + dy * nHeight / newavail
  146.                 CurrentY = CurrentY - dx * nHeight / newavail
  147.             End If
  148.             
  149.             ' Display the character.
  150.             Print ch;
  151.             
  152.             ' Move on to the next character.
  153.             avail = avail - needed
  154.             chnum = chnum + 1
  155.             If chnum > Len(txt) Then Exit Do
  156.         Loop
  157.         
  158.         ' Free the font.
  159.         newfont = SelectObject(hdc, oldfont)
  160.         DeleteObject newfont
  161.         If chnum > Len(txt) Then Exit For
  162.         x1 = x2
  163.         y1 = y2
  164.     Next pt
  165. End Sub
  166. ' Draw an assortment of text samples.
  167. Private Sub Form_Load()
  168. Const NUM_PTS = 100
  169. Dim R As Single
  170. Dim i As Integer
  171. Dim ptx(1 To NUM_PTS) As Single
  172. Dim pty(1 To NUM_PTS) As Single
  173. Dim cx As Single
  174. Dim cy As Single
  175. Dim theta As Single
  176. Dim dtheta As Single
  177.     AutoRedraw = True
  178.     ' Draw text along a spiral.
  179.     cx = ScaleWidth / 2
  180.     cy = ScaleWidth / 2
  181.     theta = 0
  182.     dtheta = 2 * PI / 50
  183.     For i = 1 To NUM_PTS
  184.         ptx(i) = cx + (i + 20) * Cos(theta)
  185.         pty(i) = cy + (i + 20) * Sin(theta)
  186.         theta = theta + dtheta
  187.     Next i
  188.     ' Display the path.
  189.     Line (ptx(1), pty(1))-(ptx(2), pty(2))
  190.     For i = 3 To NUM_PTS
  191.         Line -(ptx(i), pty(i))
  192.     Next i
  193.     ' Place text along the path.
  194.     CurveText "Rotated fonts usually give the best results on a smooth curve drawn in a relatively large, bold font.", NUM_PTS, ptx, pty, True, 25, 0, 700, False, False, False, DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS, CLIP_LH_ANGLES Or CLIP_DEFAULT_PRECIS, PROOF_QUALITY, TRUETYPE_FONTTYPE, "Times New Roman"
  195. End Sub
  196.