|
Other Tips
All Tips
By Date
By Subject
API (33)
Bit
Manipulation (3)
Clipboard (3)
Combo
Box (5)
Desktop (3)
GDI (13)
Graphics (13)
Internet (2)
Interprocess
Comms (3)
Keyboard (2)
Mouse (1)
Shell (1)
Sprites (1)
Subclassing (3)
Text
Box (2)
Windows (11)
Windows
Controls (10)
Submit
|
The Non-Client area of a window is defined as the area you don't draw on; i.e. the
window border, caption, menu bar and scroll bars. Whilst it is easy to get the colours
that Windows uses to display these items (the VB enumeration SystemColorConstants
supplies all the OLE_COLOR versions of these colours, and these can easily be converted
into an actual colour using the OLETranslateColor function, as described
in the tip Get an RGB Colour from an OLE_COLOR), it isn't
so straightforward to get the fonts and sizes.
Information about the fonts and sizes
windows uses to draw these areas can be accessed via the SystemParametersInfo call,
passing the action code SPI_GETNONCLIENTMETRICS. The data is then passed back in
a NONCLIENTMETRICS structure. This tip shows all the declares required to get this
information and to interpret it into VB readable information.
Start a new project in VB, and add a class module. Set the class module's name to
cNCMetrics and then add the following code to the class:
Private Const SPI_GETICONMETRICS = 45
Private Const SPI_GETICONTITLELOGFONT = 31
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
' Normal log font structure:
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(LF_FACESIZE) As Byte
End Type
Private Enum CNCMetricsFontWeightConstants
FW_DONTCARE = 0
FW_THIN = 100
FW_EXTRALIGHT = 200
FW_ULTRALIGHT = 200
FW_LIGHT = 300
FW_NORMAL = 400
FW_REGULAR = 400
FW_MEDIUM = 500
FW_SEMIBOLD = 600
FW_DEMIBOLD = 600
FW_BOLD = 700
FW_EXTRABOLD = 800
FW_ULTRABOLD = 800
FW_HEAVY = 900
FW_BLACK = 900
End Enum
' For some bizarre reason, maybe to do with byte
' alignment, the LOGFONT structure we must apply
' to NONCLIENTMETRICS seems to require an LF_FACESIZE
' 4 bytes smaller than normal:
Private Type NMLOGFONT
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(LF_FACESIZE - 4) 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 NMLOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As NMLOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As NMLOGFONT
lfStatusFont As NMLOGFONT
lfMessageFont As NMLOGFONT
End Type
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
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
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private m_tNCM As NONCLIENTMETRICS
Private m_tLF As LOGFONT
Public Enum CNCMetricsFontTypes
IconFont = 1
CaptionFont = 2
SMCaptionFont = 3
MenuFOnt = 4
StatusFont = 5
MessageFont = 6
End Enum
Public Function GetMetrics() As Boolean
Dim lR As Long
' Get Non-client metrics:
m_tNCM.cbSize = 340
lR = SystemParametersInfo( _
SPI_GETNONCLIENTMETRICS, _
0, _
m_tNCM, _
0)
If (lR 0) Then
' Get icon font:
lR = SystemParametersInfo( _
SPI_GETICONTITLELOGFONT, _
0, _
m_tLF, _
0)
GetMetrics = (lR 0)
End If
End Function
Property Get Font( _
ByVal hDC As Long, _
ByVal eFontNum As CNCMetricsFontTypes _
) As StdFont
Dim lR As Long
Dim tLF As LOGFONT
Select Case eFontNum
Case StatusFont
CopyMemory tLF, m_tNCM.lfStatusFont, LenB(m_tNCM.lfStatusFont)
Case SMCaptionFont
CopyMemory tLF, m_tNCM.lfSMCaptionFont, LenB(m_tNCM.lfSMCaptionFont)
Case MessageFont
CopyMemory tLF, m_tNCM.lfMessageFont, LenB(m_tNCM.lfMessageFont)
Case MenuFOnt
CopyMemory tLF, m_tNCM.lfMenuFont, LenB(m_tNCM.lfMenuFont)
Case IconFont
CopyMemory tLF, m_tLF, LenB(m_tLF)
Case CaptionFont
CopyMemory tLF, m_tNCM.lfCaptionFont, LenB(m_tNCM.lfCaptionFont)
Case Else
Exit Property
End Select
' This demonstrates how to return a VB style font.
' If you want an API hFont, just do this:
' hFont = CreateFontIndirect(tLF)
' Remember to use DeleteObject hFont when you've
' finished with it.
Dim sFnt As New StdFont
pLogFontToStdFont tLF, hDC, sFnt
Set Font = sFnt
End Property
Private Sub pLogFontToStdFont(ByRef tLF As LOGFONT, ByVal hDC As Long, ByRef sFnt As StdFont)
With sFnt
.Name = StrConv(tLF.lfFaceName, vbUnicode)
If tLF.lfHeight
.Size = Abs((72# / GetDeviceCaps(hDC, LOGPIXELSY)) * tLF.lfHeight)
Else
.Size = tLF.lfHeight
End If
.Charset = tLF.lfCharSet
.Italic = Not (tLF.lfItalic = 0)
.Underline = Not (tLF.lfUnderline = 0)
.Strikethrough = Not (tLF.lfStrikeOut = 0)
.Bold = (tLF.lfWeight > FW_REGULAR)
End With
End Sub
Property Get CaptionHeight() As Long
CaptionHeight = m_tNCM.iCaptionHeight
End Property
Property Get CaptionWIdth() As Long
CaptionWIdth = m_tNCM.iCaptionWidth
End Property
Property Get MenuHeight() As Long
MenuHeight = m_tNCM.iMenuHeight
End Property
Property Get MenuWidth() As Long
MenuWidth = m_tNCM.iMenuWidth
End Property
Property Get ScrollHeight() As Long
ScrollHeight = m_tNCM.iScrollHeight
End Property
Property Get ScrollWidth() As Long
ScrollWidth = m_tNCM.iScrollWidth
End Property
Property Get SMCaptionHeight() As Long
SMCaptionHeight = m_tNCM.iSMCaptionHeight
End Property
Property Get SMCaptionWIdth() As Long
SMCaptionWIdth = m_tNCM.iSMCaptionWidth
End Property
Property Get BorderWidth() As Long
BorderWidth = m_tNCM.iBorderWidth
End Property
To try out the code, add a Label control to your test project's main form.
Rename the Label control to lblSample, set the AutoSize property to
True and then make five copies of it, creating a control array of lblSample() controls
in a column.
Finally, add another Label control called lblInfo, and again set AutoSize to True.
Then add this code to the form's Form_Load event:
Private Sub Form_Load()
Dim cNC As New cNCMetrics
cNC.GetMetrics
Set lblSample(0).Font = cNC.Font(Me.hDC, CaptionFont)
Set lblSample(1).Font = cNC.Font(Me.hDC, IconFont)
Set lblSample(2).Font = cNC.Font(Me.hDC, MenuFOnt)
Set lblSample(3).Font = cNC.Font(Me.hDC, MessageFont)
Set lblSample(4).Font = cNC.Font(Me.hDC, SMCaptionFont)
Set lblSample(5).Font = cNC.Font(Me.hDC, StatusFont)
lblInfo.Caption = "BorderWidth: " & cNC.BorderWidth _
& vbCrLf & "Caption Height: " & cNC.CaptionHeight _
& vbCrLf & "Caption Width:" & cNC.CaptionWIdth _
& vbCrLf & "Menu Height:" & cNC.MenuHeight _
& vbCrLf & "Menu Width:" & cNC.MenuWidth _
& vbCrLf & "Scrollbar Height:" & cNC.ScrollHeight _
& vbCrLf & "Scrollbar Width:" & cNC.ScrollWidth _
& vbCrLf & "SmallCap Height:" & cNC.SMCaptionHeight _
& vbCrLf & "SmallCap Width:" & cNC.SMCaptionWIdth
End Sub
Run the project. The first six label controls will have their font changed to match the caption
font, icon font, menu font, message box font, small caption font and status bar font respectively.
The final label control will display the widths and heights of the various non-client areas of
the window.
|
Author: