Attribute VB_Name = "modFonts"
Option Explicit


'=============================================================================================================
'
' modFonts Module
' ---------------
'
' Created By  : Kevin Wilson
'               http://www.TheVBZone.com   ( The VB Zone )
'               http://www.TheVBZone.net   ( The VB Zone .net )
'
' Last Update : May 2, 2000
'
' VB Versions : 5.0 / 6.0
'
' Requires    : NOTHING
'
' Description : This module was created to easily list all the usable fonts in a ListBox, ComboBox, or
'               multi-lined TextBox control.
'
' Example Use :
'
'  FontsIntoListBox Me, List1, True, True
'
'=============================================================================================================
'
' LEGAL:
'
' You are free to use this code as long as you keep the above heading information intact and unchanged. Credit
' given where credit is due.  Also, it is not required, but it would be appreciated if you would mention
' somewhere in your compiled program that that your program makes use of code written and distributed by
' Kevin Wilson (www.TheVBZone.com).  Feel free to link to this code via your web site or articles.
'
' You may NOT take this code and pass it off as your own.  You may NOT distribute this code on your own server
' or web site.  You may NOT take code created by Kevin Wilson (www.TheVBZone.com) and use it to create products,
' utilities, or applications that directly compete with products, utilities, and applications created by Kevin
' Wilson, TheVBZone.com, or Wilson Media.  You may NOT take this code and sell it for profit without first
' obtaining the written consent of the author Kevin Wilson.
'
' These conditions are subject to change at the discretion of the owner Kevin Wilson at any time without
' warning or notice.  Copyright© by Kevin Wilson.  All rights reserved.
'
'=============================================================================================================


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(32)   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 List_Text() As String
Public List_Count As Long

Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Public Declare Function GetDesktopWindow Lib "USER32" () As Long
Public Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, lParam As Any, dw As Any) As Long

Public Function EnumFontFamProc(lpNLF As LOGFONT, lpntm As NEWTEXTMETRIC, ByVal FontType As Long, lParam As Long) As Long
On Error Resume Next
  
  Dim fontName As String
  
  ' Convert the returned string to Unicode
  fontName = StrConv(lpNLF.lfFaceName, vbUnicode)
  
  ' Add the font to the array
  List_Count = List_Count + 1
  ReDim Preserve List_Text(List_Count) As String
  List_Text(List_Count) = Left(fontName, InStr(fontName, vbNullChar) - 1)
  
  ' Continue enumeration
  EnumFontFamProc = 1
  
End Function

Public Function FontsIntoListBox(ByRef ListBoxToUse As ListBox, Optional ByVal SortList As Boolean = True, Optional ByVal SortAssending As Boolean = True)
On Error Resume Next
  
  Dim MyCounter As Long
  Dim TheDC As Long
  Dim TempLOGFONT As LOGFONT
  
  ' Get the desktop's hDC so no form is needed to get a DC value
  TheDC = GetDesktopDC
  If TheDC = 0 Then
    Exit Function
  End If
  
  ' Clear the variables to hold the information
  List_Count = 0
  Erase List_Text
  ListBoxToUse.Clear
  
  ' Put all the fonts into the variables
  EnumFontFamiliesEx TheDC, TempLOGFONT, AddressOf EnumFontFamProc, ByVal 0&, ByVal 0&
  DeleteDC TheDC
  If List_Count = 0 Then
    Exit Function
  End If
  
  ' Sort the list
  If SortList = True Then
    SortListArray SortAssending
  End If
  
  ' Put the fonts into the listbox
  For MyCounter = 1 To List_Count
    If Trim(List_Text(MyCounter)) <> "" Then
      ListBoxToUse.AddItem Trim(List_Text(MyCounter))
    End If
  Next
  ListBoxToUse.Selected(0) = True
  
End Function

Public Function FontsIntoComboBox(ByRef ComboBoxToUse As ComboBox, Optional ByVal SortList As Boolean = True, Optional ByVal SortAssending As Boolean = True)
On Error Resume Next
  
  Dim MyCounter As Long
  Dim TheDC As Long
  Dim TempLOGFONT As LOGFONT
  
  ' Get the desktop's hDC so no form is needed to get a DC value
  TheDC = GetDesktopDC
  If TheDC = 0 Then
    Exit Function
  End If
  
  ' Clear the variables to hold the information
  List_Count = 0
  Erase List_Text
  ComboBoxToUse.Clear
  
  ' Put all the fonts into the variables
  EnumFontFamiliesEx TheDC, TempLOGFONT, AddressOf EnumFontFamProc, ByVal 0&, ByVal 0&
  DeleteDC TheDC
  If List_Count = 0 Then
    Exit Function
  End If
  
  ' Sort the list
  If SortList = True Then
    SortListArray SortAssending
  End If
  
  ' Put the fonts into the listbox
  For MyCounter = 1 To List_Count
    If Trim(List_Text(MyCounter)) <> "" Then
      ComboBoxToUse.AddItem Trim(List_Text(MyCounter))
    End If
  Next
  ComboBoxToUse.Text = List_Text(0)
  
End Function

Public Function FontsIntoTextBox(ByRef TextBoxToUse As TextBox, Optional ByVal SortList As Boolean = True, Optional ByVal SortAssending As Boolean = True)
On Error Resume Next
  
  Dim MyCounter As Long
  Dim TheDC As Long
  Dim TempLOGFONT As LOGFONT
  
  ' Check if TextBox is multiline
  If TextBoxToUse.MultiLine = False Then
    MsgBox "Can not put fonts into a TextBox control that has the MultiLine property set to FALSE.", vbOKOnly + vbExclamation, "  Can't Put Fonts Into Non-Multiline TextBox"
    Exit Function
  End If
  
  ' Get the desktop's hDC so no form is needed to get a DC value
  TheDC = GetDesktopDC
  If TheDC = 0 Then
    Exit Function
  End If
  
  ' Clear the variables to hold the information
  List_Count = 0
  Erase List_Text
  TextBoxToUse.Text = ""
  
  ' Put all the fonts into the variables
  EnumFontFamiliesEx TheDC, TempLOGFONT, AddressOf EnumFontFamProc, ByVal 0&, ByVal 0&
  DeleteDC TheDC
  If List_Count = 0 Then
    Exit Function
  End If
  
  ' Sort the list
  If SortList = True Then
    SortListArray SortAssending
  End If
  
  ' Put the fonts into the listbox
  For MyCounter = 1 To List_Count
    If Trim(List_Text(MyCounter)) <> "" Then
      If MyCounter <> List_Count Then
        TextBoxToUse.Text = TextBoxToUse.Text & Trim(List_Text(MyCounter)) & vbCrLf
      Else
        TextBoxToUse.Text = TextBoxToUse.Text & Trim(List_Text(MyCounter))
      End If
    End If
  Next
  
End Function

Private Function SortListArray(Optional ByVal SortAssending As Boolean = True)
On Error Resume Next
  
  Dim MyCounter As Long
  Dim MyCounter1 As Long
  Dim TempList
  
  If SortAssending = True Then
    For MyCounter = UBound(List_Text) To 1 Step -1
      For MyCounter1 = UBound(List_Text) To 0 Step -1
        If LCase(List_Text(MyCounter)) > LCase(List_Text(MyCounter1)) Then
          TempList = List_Text(MyCounter1)
          List_Text(MyCounter1) = List_Text(MyCounter)
          List_Text(MyCounter) = TempList
        End If
      Next
    Next
  Else
    For MyCounter = 2 To UBound(List_Text)
      For MyCounter1 = 1 To UBound(List_Text)
        If LCase(List_Text(MyCounter)) > LCase(List_Text(MyCounter1)) Then
          TempList = List_Text(MyCounter1)
          List_Text(MyCounter1) = List_Text(MyCounter)
          List_Text(MyCounter) = TempList
        End If
      Next
    Next
  End If
  
End Function

Private Function GetDesktopDC() As Long
On Error Resume Next
  
  Dim hDskWnd As Long
  Dim hTempDC As Long
  Dim hMyDC As Long
  
  ' Get the handle for the desktop
  hDskWnd = GetDesktopWindow
  If hDskWnd = 0 Then
    Exit Function
  End If
  
  ' Create an hDC for the desktop
  hTempDC = GetDC(hDskWnd)
  If hTempDC = 0 Then
    Exit Function
  End If
  
  ' Create a compatible hDC for use
  hMyDC = CreateCompatibleDC(hTempDC)
  ReleaseDC hDskWnd, hTempDC
  
  ' Return the hDC of the desktop
  If hMyDC = 0 Then
    Exit Function
  Else
    GetDesktopDC = hMyDC
  End If
  
End Function