VB6 - FontWiz: The Missing Piece in Styling Your Programs

By now nearly everyone is aware of the basic technique for slapping the User Interface Themes of Windows XP and Vista onto VB6 programs. You create an application manifest that requests version 6.0 of the Common Controls, you call InitCommonControlsEx() before loading your first Form, you put OptionButton and CheckBox controls into PictureBox controls instead of Frames, you use Microsoft Common Controls 5.0 (COMCTL32.OCX) instead of Microsoft Common Controls 6.0 (MSCOMCTL.OCX).

Old news indeed. But it does auto-adapt to changing theming from OS to OS and machine to machine for the most part.

But what about your fonts? Still using cruddy old MS Sans Serif, or do you laboriously change the Font property of every control in your Projects by hand?


Adding the FontWiz class to a VB6 project produces a predeclared global object named FontWiz to your program. You can call methods on this object at runtime to adapt the font used in Form and UserControl controls to the system-standard User Interface font. This can be used as a second step in modernizing your VB6 program's UI, after taking the steps necessary to invoke the Common Controls 6.0 themeing. It is often neglected, leaving your programs still looking crude and a bit "off."

In early versions of Windows the standard UI font is 8pt MS Sans Serif, and VB6 is hard-coded to enforce this unless you override the default manually or through new IDE module templates. Beginning with Windows 2000 the default was changed to 8pt Tahoma for a cleaner and more legible look. Starting with Vista the system default is now 9pt Segoe UI to further improve clarity, especially for non-English language characters.

But "dumb old Vb6" was never updated to accomodate the changes. Thus FontWiz was born.


To use FontWiz you just add FontWiz.cls to your Project and then add the appropriate method calls to your Project's Forms and UserControls. More complete information is available in a block of comments at the head of FontWiz.cls itself.

The attached archive contains a sample Project called FontWizDemo that does little more than show how to use the FontWiz object.

Attachment 118219

Just to flesh out the comparisons I included a screenshot showing how the program looks with the default VB6 font. Bleh.

Attachment 118221

Unfortunately, with Windows 10 and 11, using this class displays error code 378 because NONCLIENTMETRICS compatibility has changed between older and current operating systems. Thanks to Copilot, compatibility has been corrected.

Code:

---

Option Explicit

Private Const SPI_GETNONCLIENTMETRICS As Long = 41
Private Const LF_FACESIZE As Long = 32

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

'=== XP ===
Private Type NONCLIENTMETRICS_XP
    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

'=== Vista+ ===
Private Type NONCLIENTMETRICS_VISTA
    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
    iPaddedBorderWidth As Long
End Type

Private Declare Function SystemParametersInfo Lib "user32" _
    Alias "SystemParametersInfoA" ( _
    ByVal uAction As Long, _
    ByVal uParam As Long, _
    ByRef lpvParam As Any, _
    ByVal fuWinIni As Long) As Long

Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
    (ByRef Destination As Any, ByVal Length As Long)

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
    (lpVersionInformation As Any) As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private m_FontName As String
Private m_FontNameDefault As String
Private m_FontSizeDefault As Currency
Private m_FontSizeRatio As Currency

'==========================
'  SUPPORT
'==========================

Private Function IsVistaOrLater() As Boolean
    Dim os As OSVERSIONINFO
    os.dwOSVersionInfoSize = Len(os)
    GetVersionEx os
    IsVistaOrLater = (os.dwMajorVersion >= 6)
End Function

Private Function FaceNameFromBytes(B() As Byte) As String
    Dim s As String
    Dim p As Long

    ' B è ANSI, StrConv lo porta a Unicode
    s = StrConv(B, vbUnicode)

    ' tronca alla prima occorrenza di Chr$(0)
    p = InStr(1, s, vbNullChar)
    If p > 0 Then
        s = Left$(s, p - 1)
    End If

    FaceNameFromBytes = s
End Function

'==========================
'  FONT APPLICATION
'==========================

Public Sub AdjustControl(ByVal Control As Control)
    With Control.Font
        If .Name = m_FontNameDefault Then
            .Name = m_FontName
            .Size = .Size * m_FontSizeRatio
            If .Size < 8 Then .Size = 8
        End If
    End With
End Sub

Public Sub AdjustControls(ByVal Controls As Object)
    Dim c As Control
    On Error Resume Next
    For Each c In Controls
        AdjustControl c
    Next
    On Error GoTo 0
End Sub

'==========================
'  INIT
'==========================

Private Sub Class_Initialize()
    Dim sysFontSize As Currency
    Dim fonDefault As StdFont
    Dim B() As Byte

    If IsVistaOrLater() Then
        Dim ncmV As NONCLIENTMETRICS_VISTA
        ZeroMemory ncmV, LenB(ncmV)
        ncmV.cbSize = LenB(ncmV)
        SystemParametersInfo SPI_GETNONCLIENTMETRICS, 0, ncmV, 0

        B = ncmV.lfMessageFont.lfFaceName
        sysFontSize = ncmV.lfMessageFont.lfHeight
    Else
        Dim ncmX As NONCLIENTMETRICS_XP
        ZeroMemory ncmX, LenB(ncmX)
        ncmX.cbSize = LenB(ncmX)
        SystemParametersInfo SPI_GETNONCLIENTMETRICS, 0, ncmX, 0

        B = ncmX.lfMessageFont.lfFaceName
        sysFontSize = ncmX.lfMessageFont.lfHeight
    End If

    Set fonDefault = New StdFont
    m_FontNameDefault = fonDefault.Name
    m_FontSizeDefault = fonDefault.Size

    sysFontSize = sysFontSize * Screen.TwipsPerPixelY / 1440
    If sysFontSize < 0 Then sysFontSize = -sysFontSize

    m_FontSizeRatio = sysFontSize / m_FontSizeDefault
    m_FontName = FaceNameFromBytes(B)
End Sub

'==========================
'  PROPERTY
'==========================

Public Property Get FontName() As String
    FontName = m_FontName
End Property

Public Property Get FontNameDefault() As String
    FontNameDefault = m_FontNameDefault
End Property

Public Property Get FontSizeDefault() As Currency
    FontSizeDefault = m_FontSizeDefault
End Property

---

These are the corrections made to the class...