'required for font API functions
'font enumeration types
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Const TRUETYPE_FONTTYPE = &H4
Private Const MIM_MAXHEIGHT As Long = &H1
Private Const MNS_NOCHECK  As Long = &H80000000

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

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

Private Type MENUINFO
   cbSize As Long
   fMask As Long
   dwStyle As Long
   cyMax As Long
   hbrBack As Long
   dwContextHelpID As Long
   dwMenuData As Long
End Type

Private 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

Private 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 Declare Function EnumFontFamilies Lib "gdi32" Alias _
   "EnumFontFamiliesA" _
   (ByVal hDC As Long, _
    ByVal lpszFamily As String, _
    ByVal lpEnumFontFamProc As Long, _
    lparam As Any) As Long

Private Declare Function SetMenuInfo Lib "user32" _
  (ByVal hmenu As Long, _
   mi As MENUINFO) As Long
   
Public Declare Function GetMenu Lib "user32" _
  (ByVal hwnd As Long) As Long
  
Public Declare Function GetSubMenu Lib "user32" _
  (ByVal hmenu As Long, _
   ByVal nPos As Long) As Long
   
Private Declare Function lstrlenW Lib "kernel32" _
  (ByVal lpString As Long) As Long
         

Public Function SetMenuScroll(frm As Form, ByVal hmenu As Long) As Boolean

  'Add scrollbars to the menu if the
  'menu will exceed the form ScaleHeight.
  'Note that if the form height is less than
  '960, three things could happen:
  'a) only one menu item will be visible,
  'plus the two scroll arrows.
  'b) no menu items are visible,
  'just the arrows, or
  'c) if too small for even the arrows,
  'the call is ignored and the entire
  'menu is shown.
   Dim mi As MENUINFO
   Dim tmpScalemode As Long

  'In order to calculate the menu height
  'the form is passed to this routine,
  'the form's current ScaleMode is saved
  'to a temp variable, the ScaleMode is set
  'to vbTwips, the required height is calculated
  'then the form' original ScaleMode is restored.
  
   tmpScalemode = frm.ScaleMode
   frm.ScaleMode = vbPixels
   
   With mi
      .cbSize = Len(mi)
      .fMask = MIM_MAXHEIGHT
      .cyMax = frm.ScaleHeight 'pixels!
   End With

   Call SetMenuInfo(hmenu, mi)
   
  'clean up
   frm.ScaleMode = tmpScalemode

End Function


Private Function TrimNull(startstr As String) As String

   TrimNull = Left$(startstr, lstrlenW(StrPtr(startstr)))
   
End Function


Public Function EnumFontFamProc(lpNLF As LOGFONT, _
                                lpNTM As NEWTEXTMETRIC, _
                                ByVal FontType As Long, _
                                ByVal lparam As Long) As Long

   Static currCount As Long
    
   If FontType = TRUETYPE_FONTTYPE Then
    
      Select Case lparam
         Case False
        
           'just counting fonts!
            fontCount = fontCount + 1
           
           'reset the local static variable 
           'used when True is passed
            currCount = 0
           
        Case True
          
        'increment the counter, convert
        'the font string from Unicode to
        'ANSI and assign to array
         currCount = currCount + 1
         fontArray(currCount) = TrimNull(StrConv(lpNLF.lfFaceName, vbUnicode))

      End Select
      
   End If
   
  'either way, return success
  'to continue enumeration until done
   EnumFontFamProc = 1

End Function


Public Sub CreateFontMenu(frm As Form)

   Dim cnt As Long
   
   With frm
   
      If .mnuFonts.Count > 1 Then Exit Sub
      
      For cnt = LBound(fontArray) To UBound(fontArray)
        
         If cnt = 1 Then
            .mnuFonts(0).Caption = fontArray(cnt)
         Else
           'the menu index is 0-based, 
           'so 1 has to be subtracted
            Load .mnuFonts(cnt - 1)
            .mnuFonts(cnt - 1).Caption = fontArray(cnt)
         End If
   
      Next
   
   End With
End Sub


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

   Dim i As Long
   Dim j As Long
   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