vbAccelerator - Contents of code file: cNCMetrics.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cNCMetrics"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Const SPI_GETICONMETRICS = 45
Private Const SPI_GETICONTITLELOGFONT = 31
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

' Normal log font structure:
Private Type LOGFONT
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName(LF_FACESIZE) As Byte
End Type
Private Enum CNCMetricsFontWeightConstants
   FW_DONTCARE = 0
   FW_THIN = 100
   FW_EXTRALIGHT = 200
   FW_ULTRALIGHT = 200
   FW_LIGHT = 300
   FW_NORMAL = 400
   FW_REGULAR = 400
   FW_MEDIUM = 500
   FW_SEMIBOLD = 600
   FW_DEMIBOLD = 600
   FW_BOLD = 700
   FW_EXTRABOLD = 800
   FW_ULTRABOLD = 800
   FW_HEAVY = 900
   FW_BLACK = 900
End Enum
' For some bizarre reason, maybe to do with byte
' alignment, the LOGFONT structure we must apply
' to NONCLIENTMETRICS seems to require an LF_FACESIZE
' 4 bytes smaller than normal:
Private Type NMLOGFONT
   lfHeight As Long
   lfWidth As Long
   lfEscapement As Long
   lfOrientation As Long
   lfWeight As Long
   lfItalic As Byte
   lfUnderline As Byte
   lfStrikeOut As Byte
   lfCharSet As Byte
   lfOutPrecision As Byte
   lfClipPrecision As Byte
   lfQuality As Byte
   lfPitchAndFamily As Byte
   lfFaceName(LF_FACESIZE - 4) As Byte
End Type
Private Type NONCLIENTMETRICS
   cbSize As Long
   iBorderWidth As Long
   iScrollWidth As Long
   iScrollHeight As Long
   iCaptionWidth As Long
   iCaptionHeight As Long
   lfCaptionFont As NMLOGFONT
   iSMCaptionWidth As Long
   iSMCaptionHeight As Long
   lfSMCaptionFont As NMLOGFONT
   iMenuWidth As Long
   iMenuHeight As Long
   lfMenuFont As NMLOGFONT
   lfStatusFont As NMLOGFONT
   lfMessageFont As NMLOGFONT
End Type
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Declare Function SystemParametersInfo Lib "user32" Alias
 "SystemParametersInfoA" ( _
   ByVal uAction As Long, _
   ByVal uParam As Long, _
   lpvParam As Any, _
   ByVal fuWinIni As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
   lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal
 nIndex As Long) As Long
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Declare Function CreateFontIndirect Lib "gdi32" Alias
 "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
 Long

Private m_tNCM As NONCLIENTMETRICS
Private m_tLF As LOGFONT

Public Enum CNCMetricsFontTypes
   IconFont = 1
   CaptionFont = 2
   SMCaptionFont = 3
   MenuFont = 4
   StatusFont = 5
   MessageFont = 6
End Enum

Public Function GetMetrics() As Boolean
Dim lR As Long
   ' Get Non-client metrics:
   m_tNCM.cbSize = 340
   lR = SystemParametersInfo( _
     SPI_GETNONCLIENTMETRICS, _
     0, _
     m_tNCM, _
     0)
   If (lR <> 0) Then
     ' Get icon font:
     lR = SystemParametersInfo( _
       SPI_GETICONTITLELOGFONT, _
       0, _
       m_tLF, _
       0)
     GetMetrics = (lR <> 0)
   End If
End Function
Property Get Font( _
     ByVal hDC As Long, _
     ByVal eFontNum As CNCMetricsFontTypes _
   ) As StdFont
Dim lR As Long
Dim tLF As LOGFONT

   Select Case eFontNum
   Case StatusFont
     CopyMemory tLF, m_tNCM.lfStatusFont, LenB(m_tNCM.lfStatusFont)
   Case SMCaptionFont
     CopyMemory tLF, m_tNCM.lfSMCaptionFont, LenB(m_tNCM.lfSMCaptionFont)
   Case MessageFont
     CopyMemory tLF, m_tNCM.lfMessageFont, LenB(m_tNCM.lfMessageFont)
   Case MenuFont
     CopyMemory tLF, m_tNCM.lfMenuFont, LenB(m_tNCM.lfMenuFont)
   Case IconFont
     CopyMemory tLF, m_tLF, LenB(m_tLF)
   Case CaptionFont
     CopyMemory tLF, m_tNCM.lfCaptionFont, LenB(m_tNCM.lfCaptionFont)
   Case Else
     Exit Property
   End Select

   ' This demonstrates how to return a VB style font.
   ' If you want an API hFont, just do this:
   ' hFont = CreateFontIndirect(tLF)
   ' Remember to use DeleteObject hFont when you've
   ' finished with it.
   Dim sFnt As New StdFont
   pLogFontToStdFont tLF, hDC, sFnt
   Set Font = sFnt

End Property
Private Sub pLogFontToStdFont(ByRef tLF As LOGFONT, ByVal hDC As Long, ByRef
 sFnt As StdFont)
   With sFnt
     .Name = StrConv(tLF.lfFaceName, vbUnicode)
     If tLF.lfHeight < 1 Then
       .Size = Abs((72# / GetDeviceCaps(hDC, LOGPIXELSY)) * tLF.lfHeight)
     Else
       .Size = tLF.lfHeight
     End If
     .Charset = tLF.lfCharSet
     .Italic = Not (tLF.lfItalic = 0)
     .Underline = Not (tLF.lfUnderline = 0)
     .Strikethrough = Not (tLF.lfStrikeOut = 0)
     .Bold = (tLF.lfWeight > FW_REGULAR)
   End With
End Sub
Property Get CaptionHeight() As Long
   CaptionHeight = m_tNCM.iCaptionHeight
End Property
Property Get CaptionWIdth() As Long
   CaptionWIdth = m_tNCM.iCaptionWidth
End Property
Property Get MenuHeight() As Long
   MenuHeight = m_tNCM.iMenuHeight
End Property
Property Get MenuWidth() As Long
   MenuWidth = m_tNCM.iMenuWidth
End Property
Property Get ScrollHeight() As Long
   ScrollHeight = m_tNCM.iScrollHeight
End Property
Property Get ScrollWidth() As Long
   ScrollWidth = m_tNCM.iScrollWidth
End Property
Property Get SMCaptionHeight() As Long
   SMCaptionHeight = m_tNCM.iSMCaptionHeight
End Property
Property Get SMCaptionWIdth() As Long
   SMCaptionWIdth = m_tNCM.iSMCaptionWidth
End Property
Property Get BorderWidth() As Long
   BorderWidth = m_tNCM.iBorderWidth
End Property