How can I detect Title Bar font from the system registry (APIs?) so that I can apply it to my labels?
Printable View
How can I detect Title Bar font from the system registry (APIs?) so that I can apply it to my labels?
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:
Good luck!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
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 ?
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?
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?
Yes it does!