home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / CODE_UPLOAD114251172000.psc / CLogFont.cls next >
Encoding:
Visual Basic class definition  |  2000-09-29  |  6.8 KB  |  233 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "CLogFont"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = False
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. ' *********************************************************************
  15. '  Copyright ⌐1998-99 Karl E. Peterson, All Rights Reserved
  16. '  http://www.mvps.org/vb
  17. ' *********************************************************************
  18. '  Warning: This computer program is protected by copyright law and
  19. '  international treaties. Unauthorized reproduction or distribution
  20. '  of this program, or any portion of it, may result in severe civil
  21. '  and criminal penalties, and will be prosecuted to the maximum
  22. '  extent possible under the law.
  23. ' *********************************************************************
  24. Option Explicit
  25.  
  26. ' Logical Font
  27. Private Const LF_FACESIZE = 32
  28. Private Const LF_FULLFACESIZE = 64
  29.  
  30. Private Const CLIP_DEFAULT_PRECIS = 0
  31. Private Const CLIP_CHARACTER_PRECIS = 1
  32. Private Const CLIP_STROKE_PRECIS = 2
  33. Private Const CLIP_MASK = &HF
  34. Private Const CLIP_LH_ANGLES = 16
  35. Private Const CLIP_TT_ALWAYS = 32
  36. Private Const CLIP_EMBEDDED = 128
  37.  
  38. Private Const DEFAULT_QUALITY = 0
  39. Private Const DRAFT_QUALITY = 1
  40. Private Const PROOF_QUALITY = 2
  41.  
  42. Private Const DEFAULT_PITCH = 0
  43. Private Const FIXED_PITCH = 1
  44. Private Const VARIABLE_PITCH = 2
  45.  
  46. Private Const ANSI_CHARSET = 0
  47. Private Const DEFAULT_CHARSET = 1
  48. Private Const SYMBOL_CHARSET = 2
  49. Private Const SHIFTJIS_CHARSET = 128
  50. Private Const HANGEUL_CHARSET = 129
  51. Private Const CHINESEBIG5_CHARSET = 136
  52. Private Const OEM_CHARSET = 255
  53.  
  54. ' Font Families
  55. '
  56. Private Const FF_DONTCARE = 0    '  Don't care or don't know.
  57. Private Const FF_ROMAN = 16      '  Variable stroke width, serifed.
  58.  
  59. ' Times Roman, Century Schoolbook, etc.
  60. Private Const FF_SWISS = 32      '  Variable stroke width, sans-serifed.
  61.  
  62. ' Helvetica, Swiss, etc.
  63. Private Const FF_MODERN = 48     '  Constant stroke width, serifed or sans-serifed.
  64.  
  65. ' Pica, Elite, Courier, etc.
  66. Private Const FF_SCRIPT = 64     '  Cursive, etc.
  67. Private Const FF_DECORATIVE = 80 '  Old English, etc.
  68.  
  69. ' Font Weights
  70. Private Const FW_DONTCARE = 0
  71. Private Const FW_THIN = 100
  72. Private Const FW_EXTRALIGHT = 200
  73. Private Const FW_LIGHT = 300
  74. Private Const FW_NORMAL = 400
  75. Private Const FW_MEDIUM = 500
  76. Private Const FW_SEMIBOLD = 600
  77. Private Const FW_BOLD = 700
  78. Private Const FW_EXTRABOLD = 800
  79. Private Const FW_HEAVY = 900
  80.  
  81. Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
  82. Private Const FW_REGULAR = FW_NORMAL
  83. Private Const FW_DEMIBOLD = FW_SEMIBOLD
  84. Private Const FW_ULTRABOLD = FW_EXTRABOLD
  85. Private Const FW_BLACK = FW_HEAVY
  86.  
  87. Private Const OUT_DEFAULT_PRECIS = 0
  88. Private Const OUT_STRING_PRECIS = 1
  89. Private Const OUT_CHARACTER_PRECIS = 2
  90. Private Const OUT_STROKE_PRECIS = 3
  91. Private Const OUT_TT_PRECIS = 4
  92. Private Const OUT_DEVICE_PRECIS = 5
  93. Private Const OUT_RASTER_PRECIS = 6
  94. Private Const OUT_TT_ONLY_PRECIS = 7
  95. Private Const OUT_OUTLINE_PRECIS = 8
  96.  
  97. Private Type LogFont
  98.    lfHeight As Long
  99.    lfWidth As Long
  100.    lfEscapement As Long
  101.    lfOrientation As Long
  102.    lfWeight As Long
  103.    lfItalic As Byte
  104.    lfUnderline As Byte
  105.    lfStrikeOut As Byte
  106.    lfCharSet As Byte
  107.    lfOutPrecision As Byte
  108.    lfClipPrecision As Byte
  109.    lfQuality As Byte
  110.    lfPitchAndFamily As Byte
  111.    lfFaceName As String * LF_FACESIZE
  112. End Type
  113.  
  114. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LogFont) As Long
  115. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  116. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
  117.  
  118. Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
  119.  
  120. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  121. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  122. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  123.  
  124. Private m_Font As StdFont
  125. Private m_hFont As Long
  126. Private m_Rotation As Single
  127.  
  128. Public Sub CleanUp()
  129.     Class_Terminate
  130. End Sub
  131.  
  132. Private Sub Class_Terminate()
  133.    '
  134.    ' Clean-up created objects!!!
  135.    '
  136.    If m_hFont Then
  137.       Call DeleteObject(m_hFont)
  138.       Set m_Font = Nothing
  139.    End If
  140. End Sub
  141.  
  142. Public Property Set LogFont(ByVal NewFont As IFont)
  143.    If m_hFont Then
  144.       Call DeleteObject(m_hFont)
  145.       m_hFont = 0
  146.    End If
  147.    
  148.    Set m_Font = Nothing
  149.    If Not NewFont Is Nothing Then
  150.       '
  151.       ' Stash a copy of the passed object,
  152.       ' to avoid a new reference to it.
  153.       '
  154.       NewFont.Clone m_Font
  155.       m_hFont = CreateLogFont
  156.    End If
  157. End Property
  158.  
  159. Public Property Get LogFont() As IFont
  160.    Set LogFont = m_Font
  161. End Property
  162.  
  163. Public Property Let Rotation(ByVal NewVal As Single)
  164.    If NewVal <> m_Rotation Then
  165.       m_Rotation = NewVal
  166.       If m_hFont Then
  167.          Call DeleteObject(m_hFont)
  168.          m_hFont = 0
  169.       End If
  170.       If Not (m_Font Is Nothing) Then
  171.          m_hFont = CreateLogFont
  172.       End If
  173.    End If
  174. End Property
  175.  
  176. Public Property Get Rotation() As Single
  177.    Rotation = m_Rotation
  178. End Property
  179.  
  180. Public Property Get Handle() As Long
  181.    Handle = m_hFont
  182. End Property
  183.  
  184. Private Function CreateLogFont() As Long
  185.    Dim lf As LogFont
  186.    Dim hWnd As Long
  187.    Dim hDC As Long
  188.    
  189.    hWnd = GetDesktopWindow
  190.    hDC = GetDC(hWnd)
  191.    
  192.    With lf
  193.       '
  194.       ' All but two properties are very straight-forward,
  195.       ' even with rotation, and map directly.
  196.       '
  197.       .lfHeight = -(m_Font.Size * GetDeviceCaps(hDC, LOGPIXELSY)) / 72
  198.       .lfWidth = 0
  199.       .lfEscapement = m_Rotation * 10
  200.       .lfOrientation = .lfEscapement
  201.       .lfWeight = m_Font.Weight
  202.       .lfItalic = m_Font.Italic
  203.       .lfUnderline = m_Font.Underline
  204.       .lfStrikeOut = m_Font.Strikethrough
  205.       .lfClipPrecision = CLIP_DEFAULT_PRECIS
  206.       .lfQuality = PROOF_QUALITY
  207.       .lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
  208.       .lfFaceName = m_Font.Name & vbNullChar
  209.       '
  210.       ' OEM fonts can't rotate, and we must force
  211.       ' substitution with something ANSI.
  212.       '
  213.       .lfCharSet = m_Font.Charset
  214.       If .lfCharSet = OEM_CHARSET Then
  215.          If (m_Rotation Mod 360) <> 0 Then
  216.             .lfCharSet = ANSI_CHARSET
  217.          End If
  218.       End If
  219.       '
  220.       ' Only TrueType fonts can rotate, so we must
  221.       ' specify TT-only if angle is not zero.
  222.       '
  223.       If (m_Rotation Mod 360) <> 0 Then
  224.          .lfOutPrecision = OUT_TT_ONLY_PRECIS
  225.       Else
  226.          .lfOutPrecision = OUT_DEFAULT_PRECIS
  227.       End If
  228.    End With
  229.    
  230.    CreateLogFont = CreateFontIndirect(lf)
  231.    Call ReleaseDC(hWnd, hDC)
  232. End Function
  233.