如何在VB6.0中用代码加载系统字体

Question

就是通过组合框能够把系统中的字体全部加载出来，不知道是要用什么代码！

Answer 1

Option Explicit

 Private Sub Form_Load()
   Module1.FillComboWithFonts Combo1
 End Sub 

 Add a module, Module1, to the project and add the following code to the module. 

Option Explicit

 'Font enumeration types
 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

 ' ntmFlags field flags
 Public Const NTM_REGULAR = &H40&
 Public Const NTM_BOLD = &H20&
 Public Const NTM_ITALIC = &H1&

 ' tmPitchAndFamily flags
 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

 ' EnumFonts Masks
 Public Const RASTER_FONTTYPE = &H1
 Public Const DEVICE_FONTTYPE = &H2
 Public Const TRUETYPE_FONTTYPE = &H4

 Declare Function EnumFontFamilies Lib "gdi32" Alias _
    "EnumFontFamiliesA" _
    (ByVal hDC As Long, ByVal lpszFamily As String, _
    ByVal lpEnumFontFamProc As Long, LParam As Any) As Long Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
    ByVal hDC As Long) As Long

 Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _
    ByVal FontType As Long, LParam As ListBox) As Long
 Dim FaceName As String
 Dim FullName As String
   FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
   LParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
   EnumFontFamProc = 1

 End Function

 Sub FillComboWithFonts(CB As ComboBox)
 Dim hDC As Long
   CB.Clear
   hDC = GetDC(CB.hWnd)
   EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, CB
   ReleaseDC CB.hWnd, hDC
 End Sub