|
§ 5.28. Как получить стандартные шрифты?
Не секрет, что хотя Visual Basic 6.0 позволяет задавать цвета
форм и элементов управления с помощью системных,
а не фиксированных цветов, такой возможности для шрифтов
почему-то не предусмотрено; и если пользователь
изменит шрифт в апплете «Дисплей» панели управления,
на вашей программе это никак не скажется. Но это легко
исправить; просто вставьте в модуль своей программы приведенный ниже код.
Использовать его можно, например, так:
Private Sub Form_Load()
Dim c As Control
On Error Resume Next
For Each c In Me.Controls
Set c.Font = DefaultFont
If Err Then Err.Clear
Next c
On Error GoTo 0
End Sub
А вот сам код:
Public Enum enmDefaultFontType
dfCaption
dfSmallCaption
dfMenu
dfStatusAndTooltip
dfMessageBox
End Enum
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
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, _
ByVal hDC As Long) As Long
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(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 Const SPI_GETNONCLIENTMETRICS = 41
Private Const LOGPIXELSY = 90
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const AverageWeight = (FW_NORMAL + FW_BOLD) / 2
Private ncm As NONCLIENTMETRICS
Public Property Get DefaultFont( _
Optional ByVal FontType As enmDefaultFontType = dfMessageBox) As StdFont
Dim f As StdFont
Set f = New StdFont
If ncm.cbSize <> Len(ncm) Then
ncm.cbSize = Len(ncm)
SystemParametersInfo SPI_GETNONCLIENTMETRICS, 0, ncm, 0
End If
Dim lf As LOGFONT
Select Case FontType
Case dfCaption
lf = ncm.lfCaptionFont
Case dfMenu
lf = ncm.lfMenuFont
Case dfMessageBox
lf = ncm.lfMessageFont
Case dfSmallCaption
lf = ncm.lfSMCaptionFont
Case dfStatusAndTooltip
lf = ncm.lfStatusFont
End Select
f.Bold = lf.lfWeight >= AverageWeight
f.Charset = lf.lfCharSet
f.Italic = lf.lfItalic
f.Strikethrough = lf.lfStrikeOut
f.Underline = lf.lfUnderline
Dim s$, l&
s = StrConv(lf.lfFaceName, vbUnicode)
l = InStr(s, vbNullChar)
If l <> 0 Then s = Left$(s, l - 1)
f.Name = s
Dim hDC&
hDC = GetDC(0)
f.Size = -lf.lfHeight * 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
Set DefaultFont = f
End Property
|
|