Visual Basic Screen & System Metrics

SystemParametersInfo: Non-Client Window Font Info
     
Posted:   Tuesday December 7, 1999
Updated:   Monday December 26, 2011
     
Applies to:   VB4-32, VB5, VB6
Developed with:   VB6, Windows NT4
OS restrictions:   None
Author:   VBnet - Randy Birch
     
 Prerequisites
None.

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.

 BAS Module Code
None.

 
 Form Code
Toss a command button (Command1) and a listview (ListView1) onto a form. Add seven columns to the listview, set to report mode, and add the following code :

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
 Comments

 
 

PayPal Link
Make payments with PayPal - it's fast, free and secure!

 
 
 
 

Copyright 1996-2011 VBnet and Randy Birch. All Rights Reserved.
Terms of Use  |  Your Privacy

 

Hit Counter