'in a form Private Sub Form_Load() 'KPD-Team 2000 'URL: http://www.allapi.net/ 'E-Mail: KPDTeam@Allapi.net Me.AutoRedraw = True EnumFonts Me.hDC, vbNullString, AddressOf EnumFontProc, 0 End Sub 'in a module Private Const LF_FACESIZE = 32 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 Declare Function EnumFonts Lib "gdi32" Alias "EnumFontsA" (ByVal hDC As Long, ByVal lpsz As String, ByVal lpFontEnumProc As Long, ByVal lParam As Long) As Long Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long) Function EnumFontProc(ByVal lplf As Long, ByVal lptm As Long, ByVal dwType As Long, ByVal lpData As Long) As Long Dim LF As LOGFONT, FontName As String, ZeroPos As Long CopyMemory LF, ByVal lplf, LenB(LF) FontName = StrConv(LF.lfFaceName, vbUnicode) ZeroPos = InStr(1, FontName, Chr$(0)) If ZeroPos > 0 Then FontName = Left$(FontName, ZeroPos - 1) Form1.Print FontName EnumFontProc = 1 End Function |