Получение всех шрифтов в системе

Ответы на вопросы, чаще всего задаваемые в форумах VBStreets. Для тех, кому лень искать.
hCORe
VB - Экстремал
VB - Экстремал
Аватара пользователя
 
Сообщения: 2332
Зарегистрирован: 22.02.2003 (Сб) 15:21
Откуда: parent directory

Получение всех шрифтов в системе

Сообщение hCORe » 26.12.2004 (Вс) 15:06

Пример не мой...

Вставьте этот код в стандартный модуль:
Код: Выделить всё
Option Explicit

Private Const DEFAULT_CHARSET = 1
Private Const NTM_REGULAR = &H40&
Private Const NTM_BOLD = &H20&
Private Const NTM_ITALIC = &H1&
Private Const TMPF_FIXED_PITCH = &H1
Private Const TMPF_VECTOR = &H2
Private Const TMPF_DEVICE = &H8
Private Const TMPF_TRUETYPE = &H4
Private Const ELF_VERSION = 0
Private Const ELF_CULTURE_LATIN = 0
Private Const RASTER_FONTTYPE = &H1
Private Const DEVICE_FONTTYPE = &H2
Private Const TRUETYPE_FONTTYPE = &H4
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

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 As String * 16  'LF_FACESIZE
End Type

Private Type NEWTEXTMETRIC
    tmHeight As Long
    tmAscent As Long
    tmDescent As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet As Byte
    ntmFlags As Long
    ntmSizeEM As Long
    ntmCellHeight As Long
    ntmAveWidth As Long
End Type

Public Type ENUMLOGFONTEX
    elfLogFont As LOGFONT
    elfFullName As String * 32  'LF_FULLFACESIZE
    elfStyle As String * 16 'LF_FACESIZE
    elfScript As String * 16 'LF_FACESIZE
End Type

Private Declare Function EnumFontFamiliesEx Lib "gdi32" _
Alias "EnumFontFamiliesExA" (ByVal hDC As Long, _
lpLogFont As LOGFONT, ByVal _
lpEnumFontProc As Long, ByVal lParam As Long, _
ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd _
As Long) As Long


Public Function EnumFonts(Optional ByVal _
FontName As String) As Byte
Dim LF As LOGFONT
    LF.lfCharSet = DEFAULT_CHARSET
    LF.lfFaceName = FontName & vbNullChar
    EnumFontFamiliesEx GetDC(0), LF, AddressOf _
    EnumFontFamProc, ByVal 0&, 0
End Function

Private Function EnumFontFamProc(lpNLF As ENUMLOGFONTEX, _
lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, _
lParam As Long) As Byte
    With lpNLF
        Debug.Print Filter(.elfLogFont.lfFaceName), Choose( _
        FontType + 1, "Device", "Raster", "Device", , "TrueType")
        Debug.Print , Filter(.elfFullName), _
        Filter(.elfStyle), Filter(.elfScript)
    End With
    EnumFontFamProc = 1
End Function

Private Function Filter(ByVal Data As String) As String
    Filter = StrConv(Data, vbUnicode)
    Filter = Left(Filter, InStr(Filter, vbNullChar) - 1)
End Function


Использование:
1) Перечисление всех шрифтов
Код: Выделить всё
EnumFonts

2) Перечисление шрифтов в семействе
Код: Выделить всё
EnumFonts "<имя семейства>"


Печатается имя семейства шрифтов, тип, полное имя, стиль и язык.
Моду создают модоки, а распространяют модозвоны.

Вернуться в Популярные вопросы

Кто сейчас на конференции

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2

    TopList