Populate Combobox with font names

Question

I want to populate a combobox on a userform with available fonts on a pc, when the userform is initialized. i have written a code for it, but it just gives me an error:

Run-time error '-2147467259 (80004005)':
Method 'ListCount' of Object '_CommanBarComboBox' failed

Ive tried to modify the i = 1 to i = 0, but it doesnt helped me.

Private Sub UserForm_Initialize()
Image3.Visible = False
Image6.Visible = False

Dim FontList
Dim i
CreatePapers.ComboBox1.Clear
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
For i = 1 To FontList.ListCount
CreatePapers.ComboBox1.AddItem FontList.List(i + 1)
Next i
End Sub

EDIT:

I modified the code, the error is gone, however, nothing is filled into the combobox.

 Dim FontList As CommandBarControl
Dim i As Long
Dim Tempbar As CommandBar
CreatePapers.ComboBox1.Clear

On Error Resume Next
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
 ' If Font control is missing, create a temp CommandBar
    If FontList Is Nothing Then
        Set Tempbar = Application.CommandBars.Add
        Set FontList = Tempbar.Controls.Add(ID:=1728)
   End If
    
For i = 1 To FontList.ListCount
Debug.Print FontList.List(i)
        CreatePapers.ComboBox1.AddItem FontList.List(i)
    Next i
    Me.ComboBox1.ListIndex = 0

'   Delete temp CommandBar if it exists
    On Error Resume Next
    Tempbar.Delete

EDIT 2: Added 2 lines of code into the above modified code as mentioned by T.M. , but it still doesnt fill up the combobox, its just empty.

EDIT 3: Changed some line in the code, but still it doesnt retrieves the fonts. Also the FontList is empty, even after the If FontList Is Nothing Then part, where it creates the temporary control bar.

Answer 1

You could shorten initializing into a more readable form by assigning a complete array to the combobox'es .List property:

Private Sub UserForm_Initialize()
    Me.ComboBox1.List = GetFontList()    ' << calling `GetFontList()  
End Sub

The array itself is the result of the following function:

Option Explicit

Function GetFontList() As Variant
    Dim FontList As CommandBarControl    ' << declare type
    On Error Resume Next                 ' provide for missing font control
    Set FontList = Application.CommandBars("Formatting").FindControl(id:=1728)
    On Error GoTo 0
    'If Font control is missing, create it on a temporary CommandBar
    If FontList Is Nothing Then
        Dim tmpBar As CommandBar
        Set tmpBar = Application.CommandBars.Add
        Set FontList = tmpBar.Controls.Add(id:=1728)
    End If

    Dim tmpList: ReDim tmpList(1 To FontList.ListCount, 1 To 1)
    'Assign fonts to array
    Dim i As Long
    For i = 1 To UBound(tmpList)
        tmpList(i, 1) = FontList.List(i)
    Next i
    
    'Delete temporary CommandBar eventually
    On Error Resume Next
    tmpBar.Delete
    'return 2-dim 1-based font array as function result
    GetFontList = tmpList
End Function

Further hints

The CommandBarControl items can be addressed by a one-based index via

FontList.List(i)

*) The combobox'es 2-dimensional .List property is zero-based, but accepts also assignment of a one-based array (as returned by above function).