Sub GetFonts()
    Dim lCount As Long, sFonts() As String
    With Application.CommandBars("Formatting")
        If Not .FindControl(ID:=172) Is Nothing Then
            With .FindControl(ID:=172)
                ReDim sFonts(1 To .ListCount)
                For lCount = 1 To .ListCount
                    sFonts(lCount) = .List(lCount)
                    Debug.Print sFonts(lCount)
                Next
            End With
        End If
    End With
End Sub

Private Sub UserForm_Initialize()
    Dim WordApp As Object, i As Integer
    Set WordApp = CreateObject("Word.Application")
    For i = 1 To WordApp.FontNames.Count
        Me.cmbFonts2.AddItem WordApp.FontNames(i)
    Next i
    WordApp.Quit
    Set WordApp = Nothing
End Sub