by Anonymous (267 Submissions)
Category: Windows System Services
Compatability: Visual Basic 4.0 (32-bit)
Difficulty: Unknown Difficulty
Originally Published: Tue 2nd February 1999
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Determine if a computer is using large or small fonts
API Declarations
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Const MM_TEXT = 1
Private Type TEXTMETRIC
tmHeight As Integer
tmAscent As Integer
tmDescent As Integer
tmInternalLeading As Integer
tmExternalLeading As Integer
tmAveCharWidth As Integer
tmMaxCharWidth As Integer
tmWeight As Integer
tmItalic As String * 1
tmUnderlined As String * 1
tmStruckOut As String * 1
tmFirstChar As String * 1
tmLastChar As String * 1
tmDefaultChar As String * 1
tmBreakChar As String * 1
tmPitchAndFamily As String * 1
tmCharSet As String * 1
tmOverhang As Integer
tmDigitizedAspectX As Integer
tmDigitizedAspectY As Integer
End Type
VBcoders
' false if using large fonts
'
' Source: the MS knowlege base article Q152136.
'
Public Function SmallFonts() As Boolean
Dim hdc As Long
Dim hwnd As Long
Dim PrevMapMode As Long
Dim tm As TEXTMETRIC
' Set the default return value to small fonts
SmallFonts = True
' Get the handle of the desktop window
hwnd = GetDesktopWindow()
' Get the device context for the desktop
hdc = GetWindowDC(hwnd)
If hdc Then
' Set the mapping mode to pixels
PrevMapMode = SetMapMode(hdc, MM_TEXT)
' Get the size of the system font
GetTextMetrics hdc, tm
' Set the mapping mode back to what it was
PrevMapMode = SetMapMode(hdc, PrevMapMode)
' Release the device context
ReleaseDC hwnd, hdc
' If the system font is more than 16 pixels high,
' then large fonts are being used
If tm.tmHeight > 16 Then SmallFonts = False
End If
End Function
