Public Type MENUITEMINFO
    cbSize As Long
    fMask As Long
    fType As Long
    fState As Long
    wID As Long
    hSubMenu As Long
    hbmpChecked As Long
    hbmpUnchecked As Long
    dwItemData As Long
    dwTypeData As String
    cch As Long
End Type

Public Declare Function GetMenu Lib "user32" _
   (ByVal hwnd As Long) As Long

Public Declare Function GetMenuItemCount Lib "user32" _
   (ByVal hMenu As Long) As Long

Public Declare Function GetSubMenu Lib "user32" _
   (ByVal hMenu As Long, ByVal nPos As Long) As Long

Public Declare Function GetMenuItemInfo Lib "user32" _
    Alias "GetMenuItemInfoA" _
   (ByVal hMenu As Long, _
    ByVal un As Long, _
    ByVal b As Boolean, _
    lpmii As MENUITEMINFO) As Long

Public Declare Function SetMenuItemInfo Lib "user32" _
    Alias "SetMenuItemInfoA" _
   (ByVal hMenu As Long, _
    ByVal uItem As Long, _
    ByVal fByPosition As Long, _
    lpmii As MENUITEMINFO) As Long

Public Const MIIM_STATE As Long = &H1
Public Const MIIM_ID As Long = &H2
Public Const MIIM_SUBMENU As Long = &H4
Public Const MIIM_CHECKMARKS As Long = &H8
Public Const MIIM_TYPE As Long = &H10
Public Const MIIM_DATA As Long = &H20

Public Const MFT_RADIOCHECK As Long = &H200
Public Const MFT_STRING As Long = &H0

Public Const RGB_STARTNEWCOLUMNWITHVERTBAR As Long = &H20
Public Const RGB_STARTNEWCOLUMN As Long = &H40
Public Const RGB_EMPTY As Long = &H100
Public Const RGB_VERTICALBARBREAK As Long = &H160
Public Const RGB_SEPARATOR As Long = &H800

'-------------------------------
'required for determining the number of fonts in the menu    
Public fontCount As Integer

'required because the fonts aren't returned
'sorted .. we'll need to do this ourselves 
Public fontArray() As String

'required for font API functions
'Font enumeration types  
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

Public 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

Public 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 Const TRUETYPE_FONTTYPE = &H4

Public Declare Function EnumFontFamilies Lib "gdi32" Alias _
   "EnumFontFamiliesA" _
   (ByVal hDC As Long, _
    ByVal lpszFamily As String, _
    ByVal lpEnumFontFamProc As Long, _
    lParam As Any) As Long


Public Function EnumFontCountProc(lpNLF As LOGFONT, _
                                  lpNTM As NEWTEXTMETRIC, _
                                  ByVal FontType As Long, _
                                  lParam As Long) As Long

    If FontType = TRUETYPE_FONTTYPE Then
       fontCount = fontCount + 1
    End If
    
   'return success to the call
    EnumFontCountProc = 1

End Function


Public Function EnumFontFamTypeProc(lpNLF As LOGFONT, _
                                    lpNTM As NEWTEXTMETRIC, _
                                    ByVal FontType As Long, _
                                    LParam As Long) As Long

    Dim FaceName As String
    Dim currFontName As String
    Static currCount as Long
    
    If FontType = TRUETYPE_FONTTYPE Then
   
     'convert the returned string from Unicode to ANSI   
      FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
   
     'increment the current counter   
      currCount = currCount + 1
      currFontName = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
      fontArray(currCount) = currFontName
      
    End If
   
   'return success to the call   
    EnumFontFamTypeProc = 1

End Function


Public Sub CreateFontMenu(fArray() As String, numColums As Integer)

   Dim i As Long
   Dim hSubMenu As Long
   Dim mnuItemCount As Long
   Dim mInfo As MENUITEMINFO
   Dim breakAt As Long
   
  'used in determining the split columns points   
   breakAt = (UBound(fontArray) / numColums)
   
  'get the menu handle   
  'this is where you specify the 0-based 
  index reflecting the Font menu position
   hSubMenu = GetSubMenu(GetMenu(Form1.hWnd), 1&)
    
   For i = LBound(fontArray) To UBound(fontArray)
     
     'because the first member of the menu control
     'array needs to be present at design time, we can't load it,
     'so some special handling is required   
     
      If i = 1 Then
         Form1.mnuFontNames(0).Caption = fontArray(i)
      Else   
        'the menu index is 0-based, so 1 has to
        'be subtracted   
         Load Form1.mnuFontNames(i - 1)
         Form1.mnuFontNames(i - 1).Caption = fontArray(i)
         DoEvents
      End If
     
     'now its time to decide if a menu break is required.
     'we have to do some tweaking because of the 0-based menu array   
      If (i - 1) Mod breakAt = 0 And i > 1 Then
         
        'retrieve the current information for the
        'last item in the menu into an MENUITEMINFO structure.
        'True means MF_BYPOSITION.   
         mInfo.cbSize = Len(mInfo)
         mInfo.fMask = MIIM_TYPE
         mInfo.fType = MFT_STRING
         mInfo.dwTypeData = Space$(256)
         mInfo.cch = Len(mInfo.dwTypeData)
         
         Call GetMenuItemInfo(hSubMenu, i - 1, True, mInfo)
        
        'modify its attributes to the new Type,
        'telling the menu to insert a break before
        'the member in the MENUITEMINFO structure.   
         mInfo.fType = RGB_STARTNEWCOLUMNWITHVERTBAR
        
        'we only want to change the style, so reset fMask   
         mInfo.fMask = MIIM_TYPE
         
        'add the break   
         Call SetMenuItemInfo(hSubMenu, i - 1, True, mInfo)
       
       End If
     
   Next

End Sub


Public Sub QSStrings(sArray() As String, l As Integer, r As Integer)

    Dim i As Integer
    Dim j As Integer
    Dim x As String
    Dim y As String
    
    i = l
    j = r
    x = sArray((l + r) / 2)

    While (i <= j)
        While (sArray(i) < x And i < r)
            i = i + 1
        Wend
        
        While (x < sArray(j) And j > l)
            j = j - 1
        Wend

        If (i <= j) Then
            y = sArray(i)
            sArray(i) = sArray(j)
            sArray(j) = y
            i = i + 1
            j = j - 1
        End If
    Wend
    
    If (l < j) Then QSStrings sArray(), l, j
    If (i < r) Then QSStrings sArray(), i, r

End Sub

Private Sub Command1_Click()
  
  'first we need to determine how many fonts
  'of the desired type will be returned.  This is
  'required to dim the font name array for sorting,
  'and to determine where to split the menu.
   EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontCountProc, Me.hWnd

  'with the count, we can ReDim the array
   ReDim fontArray(1 To fontCount) As String

  'get the fonts into the array
   EnumFontFamilies Me.hDC, vbNullString, AddressOf EnumFontFamTypeProc, Me.hWnd

  'sort them puppies
   QSStrings fontArray(), LBound(fontArray), UBound(fontArray)

  'and make a menu out of them. Note that
  'no error checking for valid values is done here!
   CreateFontMenu fontArray(), Val((Text2.Text))
   
   Command1.Enabled = False
   
End Sub


Private Sub mnuFontNames_Click(Index As Integer)

   Text1.Font.Name = (mnuFontNames(Index).Caption)

End Sub