Вставьте этот код в стандартный модуль:
- Код: Выделить всё
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 "<имя семейства>"
Печатается имя семейства шрифтов, тип, полное имя, стиль и язык.