Список системных шрифтов

Option Explicit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
''        Require reference to:
''   *    Microsoft Scripting Runtime   *
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
''Example of usage:
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Sub demo()

Dim coll As New Collection
Dim mask As String
mask = "*.shx"      ''  "*.ttf"
'Set coll = GetAcadFonts(mask)
''        Or:
Set coll = GetWinFonts(mask)
If coll.Count > 0 Then

Dim item
For Each item In coll
'' e.g. populate list box with font names:
'' ListBox1.Items.Add (CStr(item))
Debug.Print item
Next
Else
MsgBox "The font files with " & Chr(34) & mask & Chr(34) & " extension does not found in this folder"
End If
End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Function GetWinFonts(mask As String) As Collection


Dim coll As New Collection

    Dim fso, fold, fil, fc, s
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fold = fso.GetFolder(Environ("WinDir") & "\Fonts")

    Set fc = fold.Files
    
    For Each fil In fc
    If LCase(CStr(fil.Name)) Like LCase(mask) Then
    coll.Add (fil.Name)
    End If
    Next

Set fso = Nothing
Set GetWinFonts = coll
End Function


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Function GetAcadFonts(mask As String) As Collection


Dim coll As New Collection

    Dim fso, fold, fil, fc, s
    Set fso = CreateObject("Scripting.FileSystemObject")

 Set fold = fso.GetFolder(ThisDrawing.Application.Path & "\Fonts")
    Set fc = fold.Files
    
    For Each fil In fc
    If LCase(CStr(fil.Name)) Like LCase(mask) Then
    coll.Add (fil.Name)
    End If
    Next

Set fso = Nothing
Set GetAcadFonts = coll
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'