 SystemParametersInfo
is a workhorse of an API ... it can be used to both retrieve and set system-wide settings covering everything from fonts to mouse double
click rates to menu fading. Here we use SystemParametersInfo along with the NONCLIENTMETRICS and LOGFONT data types to create a set of
wrapper functions that return various font settings for the system as set through the Display Property page. Column one in the illustration
lists the SystemParametersInfo name and the corresponding Appearance property it sets.
On returning from the call, the NONCLIENTMETRICS structure contains
the scalable metrics associated with the nonclient area of a non-minimized window. This structure is used together with the
SPI_GETNONCLIENTMETRICS and SPI_SETNONCLIENTMETRICS actions of SystemParametersInfo. Only the 'Get' portion is shown here.
As is also shown in the illustration, the VB command buttons always
display the MS Sans Serif font by default, regardless of the user settings. Using the wrappers here allows you to retrieve exactly the
client's preferences to assure your app looks like all others on their system. And as the NONCLIENTMETRICS type shows, there is plenty of
other information returned. |
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const LF_FACESIZE = 32
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const LOGPIXELSY As Long = 90
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(0 To LF_FACESIZE - 1) 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 LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type
Private Enum NonClientFonts
SystemCaptionFont = 1
SystemCaptionSmallFont
SystemMenuFont
SystemMessageFont
SystemStatusFont
End Enum
'type to return info from the
'wrapper routines
Private Type SYSTEMFONTINFO
name As String
size As Single
bold As Boolean
italic As Boolean
underline As Boolean
strikeout As Boolean
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nIndex As Long) As Long
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 Sub Command1_Click()
Dim sfi As SYSTEMFONTINFO
sfi = GetSystemFontInfo(SystemCaptionFont)
Call DisplayInfo(sfi, "Captions: title bars")
sfi = GetSystemFontInfo(SystemCaptionSmallFont)
Call DisplayInfo(sfi, "Small captions: palette title")
sfi = GetSystemFontInfo(SystemMenuFont)
Call DisplayInfo(sfi, "Menus: menus, selected items")
sfi = GetSystemFontInfo(SystemMessageFont)
Call DisplayInfo(sfi, "Messages: message box text")
sfi = GetSystemFontInfo(SystemStatusFont)
Call DisplayInfo(sfi, "Status: tooltips")
End Sub
Private Function GetSystemFontInfo(nFont As NonClientFonts) As SYSTEMFONTINFO
Dim ncm As NONCLIENTMETRICS
Dim sfi As SYSTEMFONTINFO
Dim tmp As String
'set the size of the structure
ncm.cbSize = Len(ncm)
'get the non-client metrics for the system
If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, _
ncm.cbSize, _
ncm, _
0) = 1 Then
'For the font of interest, extract data
'in a similar manner from the returned
'NONCLIENTMETRICS structure:
'1 - font name is returned as Unicode,
' so convert, stripping trailing null
'
'2 - the size needs to be calculated from
' the lfHeight returned. For example, if
' lfHeight = -11, the font size is 8 points
'
'3 - if the weight is > 400, the font is
' considered medium-to-bold
'
'4 - italic, underline and strikeout are
' true when 1 is returned
Select Case nFont
Case SystemCaptionFont
tmp = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
With sfi
.name = Left$(tmp, InStr(tmp, Chr$(0)) - 1)
.size = -MulMul(ncm.lfCaptionFont.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
.bold = ncm.lfCaptionFont.lfWeight > 400
.italic = ncm.lfCaptionFont.lfItalic = 1
.underline = ncm.lfCaptionFont.lfUnderline = 1
.strikeout = ncm.lfCaptionFont.lfStrikeOut = 1
End With
Case SystemCaptionSmallFont
tmp = StrConv(ncm.lfSMCaptionFont.lfFaceName, vbUnicode)
With sfi
.name = Left$(tmp, InStr(tmp, Chr$(0)) - 1)
.size = -MulMul(ncm.lfSMCaptionFont.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
.bold = ncm.lfSMCaptionFont.lfWeight > 400
.italic = ncm.lfSMCaptionFont.lfItalic = 1
.underline = ncm.lfSMCaptionFont.lfUnderline = 1
.strikeout = ncm.lfSMCaptionFont.lfStrikeOut = 1
End With
Case SystemMenuFont
tmp = StrConv(ncm.lfMenuFont.lfFaceName, vbUnicode)
With sfi
.name = Left$(tmp, InStr(tmp, Chr$(0)) - 1)
.size = -MulMul(ncm.lfMenuFont.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
.bold = ncm.lfMenuFont.lfWeight > 400
.italic = ncm.lfMenuFont.lfItalic = 1
.underline = ncm.lfMenuFont.lfUnderline = 1
.strikeout = ncm.lfMenuFont.lfStrikeOut = 1
End With
Case SystemMessageFont
tmp = StrConv(ncm.lfMessageFont.lfFaceName, vbUnicode)
With sfi
.name = Left$(tmp, InStr(tmp, Chr$(0)) - 1)
.size = -MulMul(ncm.lfMessageFont.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
.bold = ncm.lfMessageFont.lfWeight > 400
.italic = ncm.lfMessageFont.lfItalic = 1
.underline = ncm.lfMessageFont.lfUnderline = 1
.strikeout = ncm.lfMessageFont.lfStrikeOut = 1
End With
Case SystemStatusFont
tmp = StrConv(ncm.lfStatusFont.lfFaceName, vbUnicode)
With sfi
.name = Left$(tmp, InStr(tmp, Chr$(0)) - 1)
.size = -MulMul(ncm.lfStatusFont.lfHeight, GetDeviceCaps(hdc, LOGPIXELSY), 72)
.bold = ncm.lfStatusFont.lfWeight > 400
.italic = ncm.lfStatusFont.lfItalic = 1
.underline = ncm.lfStatusFont.lfUnderline = 1
.strikeout = ncm.lfStatusFont.lfStrikeOut = 1
End With
Case Else
End Select
GetSystemFontInfo = sfi
End If
End Function
Private Sub DisplayInfo(sfi As SYSTEMFONTINFO, sMsg As String)
Dim itmX As ListItem
With sfi
Set itmX = ListView1.ListItems.Add(, , sMsg)
itmX.SubItems(1) = .name
itmX.SubItems(2) = .size & " pt"
itmX.SubItems(3) = .bold
itmX.SubItems(4) = .italic
itmX.SubItems(5) = .underline
itmX.SubItems(6) = .strikeout
End With
End Sub
Private Function MulMul(arg1 As Long, arg2 As Long, arg3 As Long) As Integer
'A weird name for a function;
'actually, it is based on the reverse of MulDiv
'(the multiple divide C macro) and since it
'returns the opposite data, I named it MulMul
'(though there is no multiplication in it!).
'I have no idea what its real corresponding
'name would be in C.
Dim tmp As Single
tmp = arg2 / arg3
tmp = arg1 / tmp
MulMul = CInt(tmp)
End Function |
