|
|
'In a module Public Const NTM_REGULAR = &H40& Public Const NTM_BOLD = &H20& Public Const NTM_ITALIC = &H1& Public Const TMPF_FIXED_PITCH = &H1 Public Const TMPF_VECTOR = &H2 Public Const TMPF_DEVICE = &H8 Public Const TMPF_TRUETYPE = &H4 Public Const ELF_VERSION = 0 Public Const ELF_CULTURE_LATIN = 0 Public Const RASTER_FONTTYPE = &H1 Public Const DEVICE_FONTTYPE = &H2 Public Const TRUETYPE_FONTTYPE = &H4 Public Const LF_FACESIZE = 32 Public Const LF_FULLFACESIZE = 64 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 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 Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" (ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, LParam As Any) As Long Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, LParam As Long) As Long Dim FaceName As String 'convert the returned string to Unicode FaceName = StrConv(lpNLF.lfFaceName, vbUnicode) 'print the form on Form1 Form1.Print Left$(FaceName, InStr(FaceName, vbNullChar) - 1) 'continue enumeration EnumFontFamProc = 1 End Function 'In a form Private Sub Form_Load() 'KPD-Team 2000 'URL: http://www.allapi.net/ 'E-Mail: KPDTeam@Allapi.net Dim hDC As Long 'set graphics mode to persistent Me.AutoRedraw = True 'enumerates the fonts EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontFamProc, ByVal 0& End Sub |