RD: System Fonts?

[Reddawn]

How can I detect Title Bar font from the system registry (APIs?) so that I can apply it to my labels?

[Joacim Andersson]

The title bar font is stored as a byte array in
HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\CaptionFont
To read this information you need to store it in a LOGFONT structure.

Here's a small demo to try it out just add a command button and a label to a form and paste this code:

Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_BINARY = 3
Private Const ERROR_SUCCESS = 0&
Private Const FW_BOLD = 700
Private Const LOGPIXELSY = 90

Private Declare Sub CopyMemory _
 Lib "kernel32" Alias "RtlMoveMemory" ( _
 Destination As Any, _
 Source As Any, _
 ByVal Length As Long)
 
Private Declare Function RegCloseKey _
 Lib "advapi32.dll" ( _
 ByVal hKey As Long) As Long

Private Declare Function RegOpenKey _
 Lib "advapi32.dll" Alias "RegOpenKeyA" ( _
 ByVal hKey As Long, _
 ByVal lpSubKey As String, _
 phkResult As Long) As Long

Private Declare Function RegQueryValueEx _
 Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
 ByVal hKey As Long, _
 ByVal lpValueName As String, _
 ByVal lpReserved As Long, _
 lpType As Long, _
 lpData As Any, _
 lpcbData As Long) As Long

Private Declare Function MulDiv _
 Lib "kernel32" ( _
 ByVal nNumber As Long, _
 ByVal nNumerator As Long, _
 ByVal nDenominator As Long) As Long

Private Declare Function GetDeviceCaps _
 Lib "gdi32" ( _
 ByVal hdc As Long, _
 ByVal nIndex As Long) As Long

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 64) As Byte
End Type

Private Function GetFont( _
 ByVal strPath As String, _
 ByVal strValueName As String) As LOGFONT
    Dim lngValueType As Long
    Dim bBuffer() As Byte
    Dim lngBufferSize As Long
    Dim lngResult As Long
    Dim hCurKey As Long
    Dim udtFont As LOGFONT

    lngResult = RegOpenKey(HKEY_CURRENT_USER, strPath, hCurKey)
    lngResult = RegQueryValueEx(hCurKey, strValueName, 0&, _
     lngValueType, ByVal 0&, lngBufferSize)
    
    If lngResult = ERROR_SUCCESS Then
        If lngValueType = REG_BINARY Then
            ReDim bBuffer(lngBufferSize - 1) As Byte
            lngResult = RegQueryValueEx(hCurKey, strValueName, 0&, _
            lngValueType, bBuffer(0), lngBufferSize)
            CopyMemory udtFont, bBuffer(0), Len(udtFont)
            GetFont = udtFont
        End If
    Else
        'there is a problem
    End If
    Call RegCloseKey(hCurKey)
End Function

Private Sub Command1_Click()
    Dim udtFont As LOGFONT
    
    Me.ScaleMode = vbTwips
    udtFont = GetFont("Control Panel\Desktop\WindowMetrics", "CaptionFont")
    With Label1.Font
        .Name = udtFont.lfFaceName
        .Bold = ((udtFont.lfWeight And FW_BOLD) = FW_BOLD)
        .Italic = CBool(udtFont.lfItalic)
        .Size = -MulDiv(udtFont.lfHeight, GetDeviceCaps(Me.hdc, LOGPIXELSY), 1440)
    End With
End Sub

Good luck!

[Reddawn]

Thanx for the long code..
I have run the code however the respond I had was not correct. Like Tahoma Bold is shown to be Times New Roman Italic.. Why could that be ?

[Joacim Andersson]

I don't know. I don't have Tahoma Bold on my computer but I've tried it with about 20 different font types and it works great on my computer.

Is it the Font of the active title bar of your window you are trying to get or have I misunderstood something?

[Reddawn]

I want to detect the font set by the user or the system default, which is declared within the appearance tab of display settings. The key is "Active Title Bar Font". Does the code you've sent apply for this?

[Joacim Andersson]

Yes it does!