VB Notebook Get System Fonts

VBNotebook Home | Functions | Get System Fonts

This routine gets the Windows system font for the target object. This routine returns the Font object for the follow objects: Caption, Small Caption, Menu, Status Bar and Message Box....

First, in General|Declarations, include the following....
__________________________________________________________________________________________

'
' Types for API Calls
'
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 - 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
'
' Constants
'
Public Enum SystemFontTypesEnum
    sfte_CaptionFont
    sfte_SmallCaptionFont
    sfte_MenuFont
    sfte_StatusFont
    sfte_MessageFont
End Enum

Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const SPI_GETNONCLIENTMETRICS = 41&
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
'
' API Calls
'
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

__________________________________________________________________________________________
...and now the routine... __________________________________________________________________________________________

Public Function GetSystemFont(ByVal nFontType As SystemFontTypesEnum) As StdFont

    Dim NCM As NONCLIENTMETRICS
    Dim nRet As Long
    Dim sFontname As String
    Dim nLogPixY As Single
    Dim fntNew As StdFont
    Dim uFont As LOGFONT

    NCM.cbSize = Len(NCM)
    nRet = SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0 &, NCM, 0&)
    If nRet = 0& Then
        Exit Function
    End If
    nLogPixY = 1440 / Screen.TwipsPerPixelY
    Select Case nFontType
        Case sfte_CaptionFont
            uFont = NCM.lfCaptionFont
        Case sfte_SmallCaptionFont
            uFont = NCM.lfSMCaptionFont
        Case sfte_MenuFont
            uFont = NCM.lfMenuFont
        Case sfte_StatusFont
            uFont = NCM.lfStatusFont
        Case sfte_MessageFont
            uFont = NCM.lfMessageFont
        Case Else
            Exit Function
    End Select
    Set fntNew = New StdFont
    With uFont
        sFontname = StrConv(.lfFaceName, vbUnicode)
        sFontname = Left$(sFontname, InStr(1, sFontname, vbNullChar) - 1)
        fntNew.Name = sFontName
        fntNew.Size = nFontSize = Abs((.lfHeight * 72) / nLogPixY)
        If .lfWeight >= FW_BOLD Then
            fntNew.Bold = True
        Else
            fntNew.Bold = False
        End If
        fntNew.Italic = cBool(.lfItalic)
    End With
    Set GetSystemFont = fntNew

End Function

__________________________________________________________________________________________