' Solution 4
Private Sub Get_Shell_Fonts()
    
    'https://stackoverflow.com/questions/7408024/how-to-get-a-font-file-name
    '-----------------------------------------------------------------------------------------------
    ' Needed Reference for Early-Binding:
    '    Library Shell32
    '        C:\Windows\SysWOW64\shell32.dll
    '        Microsoft Shell Controls And Automation
    '-----------------------------------------------------------------------------------------------
    ' Common Vars
    Dim lng_RowID      As Long      ' Base1 incr Before Use
    Dim lng_FontFamily As Long      ' Base1 incr Before Use
    Dim lng_SubFont    As Long      ' Base1 incr Before Use
    Dim str_Out        As String    ' For save As TSV Cp 1200
    
    lng_RowID = 0
    lng_FontFamily = 0
    lng_SubFont = 0
    str_Out = ""
    '-----------------------------------------------------------------------------------------------
    ' Init Shell
    Dim obj_Shell As Shell32.Shell
    Set obj_Shell = New Shell32.Shell 'Late Binding: Set obj_Shell = CreateObject("Shell.Application")
    '-----------------------------------------------------------------------------------------------
    ' Init Folder
    ' HardCoded: Set obj_Folder = obj_Shell.NameSpace("C:\Windows\Fonts")
    ' Better: Environment.SpecialFolder: Fonts = 20 = A virtual folder that contains fonts.
    Dim obj_Folder As Shell32.Folder
    Set obj_Folder = obj_Shell.NameSpace(VBA.Environ("SystemRoot") & "\Fonts")
    If obj_Folder Is Nothing Then
        Debug.Print "Can't Init Folder"
    Else
        '-------------------------------------------------------------------------------------------
        ' Collect FieldNames BrutForce
        
        ' Sample From Win 8.1 German
        
        '  0 = Name
        '  1 = Schriftschnitt
        '  2 = Ein-/ausblenden
        '  3 = Entwickelt für
        '  4 = Kategorie
        '  5 = Designer/Hersteller
        '  6 = Einbindbarkeit von Schriftarten
        '  7 = Schriftarttyp
        '  8 = Familie
        '  9 = Erstelldatum
        ' 10 = Änderungsdatum
        ' 11 = Größe
        ' 12 = Sammlung
        ' 13 = Schriftartdateinamen            = FullFileName
        ' 14 = Schriftartversion
        
        Dim int_FieldIndex      As Integer ' Base0
        Dim str_FieldName       As String
        Dim int_FieldCount      As Integer ' Base1
        Dim stra_FieldNames()   As String  ' Base0
        Dim inta_FieldIndices() As Integer ' Base0
        int_FieldCount = 0
        
        For int_FieldIndex = 0 To 1000
            '---------------------------------------------------------------------------------------
            str_FieldName = obj_Folder.GetDetailsOf(Null, int_FieldIndex)
            If str_FieldName = "" Then
                Exit For
            End If
            '---------------------------------------------------------------------------------------
            ' Enlarge Array
            ReDim Preserve inta_FieldIndices(0 To int_FieldCount)
            ReDim Preserve stra_FieldNames(0 To int_FieldCount)
            '---------------------------------------------------------------------------------------
            ' Store
            inta_FieldIndices(int_FieldCount) = int_FieldIndex
            stra_FieldNames(int_FieldCount) = str_FieldName
            '---------------------------------------------------------------------------------------
            ' Incr FieldCount
            int_FieldCount = int_FieldCount + 1
            '---------------------------------------------------------------------------------------
        Next int_FieldIndex
        '-------------------------------------------------------------------------------------------
        ' Print Fields // Header For TSV
        str_Out = "RowID" & vbTab & "FontFamilyID" & vbTab & "SubFontID"
        For int_FieldIndex = 0 To int_FieldCount - 1
            str_Out = str_Out & vbTab & stra_FieldNames(int_FieldIndex)
            Debug.Print inta_FieldIndices(int_FieldIndex), stra_FieldNames(int_FieldIndex)
        Next int_FieldIndex
        str_Out = str_Out & vbCrLf
        '-------------------------------------------------------------------------------------------
        ' Loop Files
        Dim obj_FolderItem As Shell32.FolderItem
        For Each obj_FolderItem In obj_Folder.Items
            '---------------------------------------------------------------------------------------
            lng_FontFamily = lng_FontFamily + 1
            lng_RowID = lng_RowID + 1
            lng_SubFont = 0
            '---------------------------------------------------------------------------------------
            Debug.Print
            Debug.Print lng_RowID, lng_FontFamily, lng_SubFont;
            str_Out = str_Out & lng_RowID & vbTab & lng_FontFamily & vbTab & lng_SubFont
            For int_FieldIndex = 0 To int_FieldCount - 1
                Debug.Print , obj_Folder.GetDetailsOf(obj_FolderItem, int_FieldIndex);
                str_Out = str_Out & vbTab & obj_Folder.GetDetailsOf(obj_FolderItem, int_FieldIndex)
            Next int_FieldIndex
            str_Out = str_Out & vbCrLf
            '---------------------------------------------------------------------------------------
            ' Loop Fonts in Family: is Not a Filesystem-Object // No Recursion needed: No more Subs
            Dim obj_SubFolder As Shell32.Folder
            Dim obj_SubFolderItem As Shell32.FolderItem
            If obj_FolderItem.IsFolder Then
                lng_SubFont = 0
                Set obj_SubFolder = obj_FolderItem.GetFolder
                For Each obj_SubFolderItem In obj_SubFolder.Items
                    lng_SubFont = lng_SubFont + 1
                    lng_RowID = lng_RowID + 1
                    
                    Debug.Print
                    Debug.Print lng_RowID, lng_FontFamily, lng_SubFont;
                    str_Out = str_Out & lng_RowID & vbTab & lng_FontFamily & vbTab & lng_SubFont
                    For int_FieldIndex = 0 To int_FieldCount - 1
                        Debug.Print , obj_SubFolder.GetDetailsOf(obj_SubFolderItem, int_FieldIndex);
                        str_Out = str_Out & vbTab & obj_SubFolder.GetDetailsOf(obj_SubFolderItem, int_FieldIndex)
                    Next int_FieldIndex
                    str_Out = str_Out & vbCrLf
                Next obj_SubFolderItem
            End If
        Next obj_FolderItem
    End If 'If obj_Folder Is Nothing Then
    '-----------------------------------------------------------------------------------------------
    ' CleanUp
    Set obj_SubFolderItem = Nothing
    Set obj_SubFolder = Nothing
    Set obj_FolderItem = Nothing
    Set obj_Folder = Nothing
    Set obj_Shell = Nothing
    '-----------------------------------------------------------------------------------------------
    ' Optional Store str_Out as TSV CP1200 UTF16
    ' VBA Style:
    Dim int_FileHandler As Integer, byta() As Byte
    byta() = str_Out
    int_FileHandler = FreeFile()
    Open "C:\Out.csv" For Binary As int_FileHandler  ' Sample Target !!!!!!!! Please Adjust !!!!!!!!
    Put int_FileHandler, 1, byta()
    Close int_FileHandler
    '-----------------------------------------------------------------------------------------------
    Debug.Print
    Debug.Print "wdi ******"
    '-----------------------------------------------------------------------------------------------

End Sub