FAQ по Visual Basic

Содержание / Windows API Поиск | Далее

§ 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     ' заголовок окна типа ToolWindow
    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

Автор:
Master

Предыдущий раздел Следующий раздел

© 2004. При цитировании, пожалуйста, не забудьте поставить ссылку на оригинальную страницу.