Add this code to the Class:Option ExplicitPrivate 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 TypePrivate 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 TypePrivate 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 TypePrivate Const SPI_GETNONCLIENTMETRICS = 41 Private Const SPI_SETNONCLIENTMETRICS = 42Private 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 LongPrivate m_tNCM As NONCLIENTMETRICS Private m_tLF As LOGFONTPublic Enum CNCMetricsFontTypes IconFont = 1 CaptionFont = 2 SMCaptionFont = 3 MenuFOnt = 4 StatusFont = 5 MessageFont = 6 End EnumPublic 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 FunctionProperty 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 = sFntEnd PropertyPrivate 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 SubProperty Get CaptionHeight() As Long CaptionHeight = m_tNCM.iCaptionHeight End PropertyProperty Get CaptionWIdth() As Long CaptionWIdth = m_tNCM.iCaptionWidth End PropertyProperty Get MenuHeight() As Long MenuHeight = m_tNCM.iMenuHeight End PropertyProperty Get MenuWidth() As Long MenuWidth = m_tNCM.iMenuWidth End PropertyProperty Get ScrollHeight() As Long ScrollHeight = m_tNCM.iScrollHeight End PropertyProperty Get ScrollWidth() As Long ScrollWidth = m_tNCM.iScrollWidth End PropertyProperty Get SMCaptionHeight() As Long SMCaptionHeight = m_tNCM.iSMCaptionHeight End PropertyProperty Get SMCaptionWIdth() As Long SMCaptionWIdth = m_tNCM.iSMCaptionWidth End PropertyProperty Get BorderWidth() As Long BorderWidth = m_tNCM.iBorderWidth End Property '-- End --'Paste this code into the Form_Load event:Private Sub Form_Load() Dim cNC As New cNCMetrics
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 TypePrivate 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 TypePrivate 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 TypePrivate Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42Private 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 LongPrivate m_tNCM As NONCLIENTMETRICS
Private m_tLF As LOGFONTPublic Enum CNCMetricsFontTypes
IconFont = 1
CaptionFont = 2
SMCaptionFont = 3
MenuFOnt = 4
StatusFont = 5
MessageFont = 6
End EnumPublic 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 FunctionProperty 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 = sFntEnd PropertyPrivate 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 SubProperty Get CaptionHeight() As Long
CaptionHeight = m_tNCM.iCaptionHeight
End PropertyProperty Get CaptionWIdth() As Long
CaptionWIdth = m_tNCM.iCaptionWidth
End PropertyProperty Get MenuHeight() As Long
MenuHeight = m_tNCM.iMenuHeight
End PropertyProperty Get MenuWidth() As Long
MenuWidth = m_tNCM.iMenuWidth
End PropertyProperty Get ScrollHeight() As Long
ScrollHeight = m_tNCM.iScrollHeight
End PropertyProperty Get ScrollWidth() As Long
ScrollWidth = m_tNCM.iScrollWidth
End PropertyProperty Get SMCaptionHeight() As Long
SMCaptionHeight = m_tNCM.iSMCaptionHeight
End PropertyProperty Get SMCaptionWIdth() As Long
SMCaptionWIdth = m_tNCM.iSMCaptionWidth
End PropertyProperty Get BorderWidth() As Long
BorderWidth = m_tNCM.iBorderWidth
End Property
'-- End --'Paste this code into the Form_Load event:Private Sub Form_Load() Dim cNC As New cNCMetrics
cNC.GetMetrics
Set lblSample(0).Font = cNC.Font(Me.hDC, CaptionFont)
Set lblSample(1).Font = cNC.Font(Me.hDC, IconFont)
Set lblSample(2).Font = cNC.Font(Me.hDC, MenuFOnt)
Set lblSample(3).Font = cNC.Font(Me.hDC, MessageFont)
Set lblSample(4).Font = cNC.Font(Me.hDC, SMCaptionFont)
Set lblSample(5).Font = cNC.Font(Me.hDC, StatusFont)
lblInfo.Caption = "BorderWidth: " & cNC.BorderWidth _
& vbCrLf & "Caption Height: " & cNC.CaptionHeight _
& vbCrLf & "Caption Width:" & cNC.CaptionWIdth _
& vbCrLf & "Menu Height:" & cNC.MenuHeight _
& vbCrLf & "Menu Width:" & cNC.MenuWidth _
& vbCrLf & "Scrollbar Height:" & cNC.ScrollHeight _
& vbCrLf & "Scrollbar Width:" & cNC.ScrollWidth _
& vbCrLf & "SmallCap Height:" & cNC.SMCaptionHeight _
& vbCrLf & "SmallCap Width:" & cNC.SMCaptionWIdthEnd Sub'-- End --'