home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 4 Unleashed / Visual_Basic_4_Unleashed_SAMS_Publishing_1995.iso / source / chap22 / rotate.cls < prev    next >
Encoding:
Text File  |  1995-09-24  |  3.7 KB  |  134 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "ROTATEFONT"
  6. Attribute VB_Creatable = False
  7. Attribute VB_Exposed = False
  8. Option Explicit
  9.  
  10. Private Const OUT_DEFAULT_PRECIS = 0
  11. Private Const OUT_STRING_PRECIS = 1
  12. Private Const OUT_CHARACTER_PRECIS = 2
  13. Private Const OUT_STROKE_PRECIS = 3
  14. Private Const OUT_TT_PRECIS = 4
  15. Private Const OUT_DEVICE_PRECIS = 5
  16. Private Const OUT_RASTER_PRECIS = 6
  17. Private Const OUT_TT_ONLY_PRECIS = 7
  18. Private Const OUT_OUTLINE_PRECIS = 8
  19.  
  20. Private Const CLIP_DEFAULT_PRECIS = 0
  21. Private Const CLIP_CHARACTER_PRECIS = 1
  22. Private Const CLIP_STROKE_PRECIS = 2
  23. Private Const CLIP_MASK = &HF
  24. Private Const CLIP_LH_ANGLES = 16
  25. Private Const CLIP_TT_ALWAYS = 32
  26. Private Const CLIP_EMBEDDED = 128
  27.  
  28. Private Const DEFAULT_QUALITY = 0
  29. Private Const DRAFT_QUALITY = 1
  30. Private Const PROOF_QUALITY = 2
  31.  
  32. Private Const DEFAULT_PITCH = 0
  33. Private Const FIXED_PITCH = 1
  34. Private Const VARIABLE_PITCH = 2
  35.  
  36. Private Const ANSI_CHARSET = 0
  37. Private Const DEFAULT_CHARSET = 1
  38. Private Const SYMBOL_CHARSET = 2
  39. Private Const SHIFTJIS_CHARSET = 128
  40. Private Const HANGEUL_CHARSET = 129
  41. Private Const CHINESEBIG5_CHARSET = 136
  42. Private Const OEM_CHARSET = 255
  43.  
  44. ' Font Families
  45. '
  46. Private Const FF_DONTCARE = 0    '  Don't care or don't know.
  47. Private Const FF_ROMAN = 16      '  Variable stroke width, serifed.
  48.  
  49. ' Times Roman, Century Schoolbook, etc.
  50. Private Const FF_SWISS = 32      '  Variable stroke width, sans-serifed.
  51.  
  52. ' Helvetica, Swiss, etc.
  53. Private Const FF_MODERN = 48     '  Constant stroke width, serifed or sans-serifed.
  54.  
  55. ' Pica, Elite, Courier, etc.
  56. Private Const FF_SCRIPT = 64     '  Cursive, etc.
  57. Private Const FF_DECORATIVE = 80 '  Old English, etc.
  58.  
  59. ' Font Weights
  60. Private Const FW_DONTCARE = 0
  61. Private Const FW_THIN = 100
  62. Private Const FW_EXTRALIGHT = 200
  63. Private Const FW_LIGHT = 300
  64. Private Const FW_NORMAL = 400
  65. Private Const FW_MEDIUM = 500
  66. Private Const FW_SEMIBOLD = 600
  67. Private Const FW_BOLD = 700
  68. Private Const FW_EXTRABOLD = 800
  69. Private Const FW_HEAVY = 900
  70.  
  71. Private Type LOGFONT
  72.         lfHeight As Long
  73.         lfWidth As Long
  74.         lfEscapement As Long
  75.         lfOrientation As Long
  76.         lfWeight As Long
  77.         lfItalic As Byte
  78.         lfUnderline As Byte
  79.         lfStrikeOut As Byte
  80.         lfCharSet As Byte
  81.         lfOutPrecision As Byte
  82.         lfClipPrecision As Byte
  83.         lfQuality As Byte
  84.         lfPitchAndFamily As Byte
  85.         lfFaceName As String * 32
  86. End Type
  87.  
  88. Private Declare Function CreateFontIndirect Lib "gdi32" _
  89.     Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
  90.  
  91. Private Declare Function SelectObject Lib "gdi32" _
  92.     (ByVal hDC As Long, ByVal hObject As Long) As Long
  93.  
  94. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" _
  95.     (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, _
  96.     ByVal lpString As String, ByVal nCount As Long) As Long
  97.  
  98. Private Declare Function DeleteObject Lib "gdi32" _
  99.     (ByVal hObject As Long) As Long
  100.  
  101. Private font As LOGFONT
  102.  
  103. Private Sub Class_Initialize()
  104.     font.lfHeight = 10
  105.     font.lfWidth = 0
  106.     font.lfEscapement = 0
  107.     font.lfPitchAndFamily = FF_MODERN
  108.     font.lfCharSet = ANSI_CHARSET
  109.     font.lfQuality = PROOF_QUALITY
  110.     font.lfWeight = FW_NORMAL
  111.     font.lfFaceName = ""
  112. End Sub
  113.  
  114. Public Sub setPointSize(ps As Long)
  115.     font.lfHeight = ps
  116. End Sub
  117.  
  118. Public Sub setAngle(angle As Long)
  119.     font.lfEscapement = angle * 10
  120. End Sub
  121.  
  122. Public Sub dispText(hDC As Long, text As String, x As Long, y As Long)
  123.     Dim hFont As Long
  124.     Dim hOldFont As Long
  125.  
  126.     hFont = CreateFontIndirect(font)
  127.     hOldFont = SelectObject(hDC, hFont)
  128.     TextOut hDC, x, y, text, Len(text)
  129.     hFont = SelectObject(hDC, hOldFont)
  130.     DeleteObject hFont
  131. End Sub
  132.  
  133.  
  134.