[RESOLVED] Get title bar font

[Ellis Dee]

I need to get both the font name and size of the title bar font. The following code from here gets me most of the way:

Option Explicit
 
Private Const LF_FACESIZE = 32
Private Const SPI_GETNONCLIENTMETRICS = 41
 
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(1 To LF_FACESIZE) 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 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
 
Public Function ActiveTitleBarFontName()
    Dim s As String
    Dim i As Byte
    Dim ncm As NONCLIENTMETRICS
    Dim sdfont As StdFont
    
    ncm.cbSize = Len(ncm)
    If SystemParametersInfo(41, ncm.cbSize, ncm, 0) Then
        s = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
        i = InStr(s, vbNullChar)
        If i > 0 Then s = Left(s, i - 1)
    End If
    ActiveTitleBarFontName = s
End Function

I must be a little slow, though, because I can't figure out how to determine the font size from that structure. On my system the ActiveTitleBar font is Tahoma 8, but the lfCaptionFont structure has the following values:

lfHeight = -11
lfWeight = 700

Little help?

[Edgemeal]

Not sure how its done, but a quick search on PSC found this example,

Function GetCaptionFont...
Dim WinFont As LogFont
"Size = " & -(WinFont.FontHeight * (72 / GetDeviceCaps(Me.hDC, LOGPIXELSY)))

[Ellis Dee]

Yeah, I just found this article on vbnet which has everything I'm looking for and then some. Notably it also returns Bold information, which can effect font sizes for display purposes. I'll post my finished function once I pare down that ocean of code to the bare minimum.

Thanks for the quick response of the formula. I found a second solution that posted the same thing but I was going crazy trying to figure out where the heck hdc came from. My solution kept bombing out because I had moved the code to a bas module. I probably wouldn't have figured it out for a while with the vbnet code either, so your short and sweet response was actually quite helpful. Thanks much.

[Edgemeal]

That vbnet example seems to be good, my font size is set to 10 and it returns 10, whereas that PSC code returns 9.75.

[Ellis Dee]

I would lend more credence to the PSC code simply because actual font sizes are very rarely perfect integers. As I found while writing my form resizing code, when you set a font to a size it usually snaps to a decimal value near what you sent. For example, setting a font to 10 will almost always result in an actual font of size 9.75.

I think the distinction is mostly academic, though, because you'll get the same result if you set the font to either 10 or 9.75. On a conceptual level it's probably better to get the 10 value simply because you'll then be letting the OS handle the actual sizing the same way it does for the Appearance settings.

I'm writing an mp3 player that handles 4+ hour long files gracefully, (eg: radio show mp3 files,) and would like it to snap to the titlebar similar to how WinAmp looks. I figured the ideal way to size the font would be to just use the OS's titlebar font size since that's where it will be.

I'd rate you but once again I have to spread some around first. Which is really too bad; you and LaVolpe would both have gotten quite a bit more rating from me for all the threads you two have helped me in.

[Ellis Dee]

Here's my finished solution, which will set a given form's font to the system titlebar font. The following goes in a bas module:

Option Explicit
 
Private Const LF_FACESIZE = 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
 
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 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
 
' Sets a form's font to Windows Titlebar font
' Thanks to Randy Birch of VBNet
Public Sub SetFormFontToTitlebarFont(pfrm As Form)
    Const SPI_GETNONCLIENTMETRICS = 41
    Const LOGPIXELSY As Long = 90
    Dim typMetric As NONCLIENTMETRICS
    
    typMetric.cbSize = Len(typMetric)
    If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, typMetric.cbSize, typMetric, 0) = 1 Then
        pfrm.FontName = StrConv(typMetric.lfCaptionFont.lfFaceName, vbUnicode)
        pfrm.FontSize = -typMetric.lfCaptionFont.lfHeight / (GetDeviceCaps(pfrm.hdc, LOGPIXELSY) / 72)
        pfrm.FontBold = (typMetric.lfCaptionFont.lfWeight > 400)
    End If
End Sub

Sample usage:

Private Sub Form_Load()
    SetFormFontToTitlebarFont Me
End Sub