Comments

1. Keith Alchin
   14 Jun 2006 at 07:44

   Sorry late with a reply only seen this today. You have probably already discovered the answer but here is one anyway.

   1. Create a New Form

   2. Create either a standard combo on the form or put a combo in the Toolbar depending on your application. I have tested it in VB Express 2005 and it works.

   2. Put this code in the Load event of the Form

   'This Code loads a combo box using .net

   Dim fnt As System.Drawing.Text.InstalledFontCollection = New System.Drawing.Text.InstalledFontCollection
           Dim fFamily As FontFamily
   

           For Each fFamily In fnt.Families
               ToolStripComboBox2.Items.Add(fFamily.Name)
           Next
   
   

   Regards

2. Henri Bogaarts
   04 Apr 2006 at 15:41

   This is great!

   But how can i get it to work in VB express 2005 (so i guess vb .net v2.0) ?

   I took a shot at it myself, but as you can see i get a few errors in the 2 functions. I'm a newbie and have not got a clue how i can make this work.

   anyway here is the the changed code

   ---
   Option Explicit On
   Module
   Module1
   

   'Font enumeration types
   
   Public Const LF_FACESIZE = 32
   
   Public Const LF_FULLFACESIZE = 64
   
   Public Structure LOGFONT
   
      Dim lfHeight As Long
   
      Dim lfWidth As Long
   
      Dim lfEscapement As Long
   
      Dim lfOrientation As Long
   
      Dim lfWeight As Long
   
      Dim lfItalic As Byte
   
      Dim lfUnderline As Byte
   
      Dim lfStrikeOut As Byte
   
      Dim lfCharSet As Byte
   
      Dim lfOutPrecision As Byte
   
      Dim lfClipPrecision As Byte
   
      Dim lfQuality As Byte
   
      Dim lfPitchAndFamily As Byte
   
      ' original line was lfFaceName(LF_FACESIZE) As Byte
      'changed in the following line but am not sure if this is correct
   
   
      Dim lfFaceName As Byte
   
   End Structure

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

   ' 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, ByVal LParam As Long) 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

   Dim vbUnicode As System.Text.UnicodeEncoding

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

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

   End

   Module
   
   ---  

   Can anybody change the above code in a working version??

    

    

    

3. Developer Fusion Bot
   01 Jan 1999 at 00:00

   This thread is for discussions of A Faster Font List/Combo.