VBA: Получить список шрифтов программы Excel с помощью макроса

[Firetol]

Как получить список шрифтов Excel в массив?
Список шрифтов в экселе находится здесь: вкладка Главная - группа Шрифт - список со шрифтами.

[Администратор]

Макрос

Sub Макрос()

    Dim FontsComboBox As CommandBarComboBox, fonts()
    Dim i As Long
   
    '1. Создание ссылки на элемент, который находился на панели инструментов "Форматирование".
        ' Эта панель была в Excel 2003. Сейчас её не видно, но она существует.
    Set FontsComboBox = Application.CommandBars("Formatting").FindControl(ID:=1728)
   
    '2. Создание ячеек в массиве "fonts".
    ReDim fonts(1 To FontsComboBox.ListCount)
   
    '3. Запись шрифтов в массив "fonts".
    For i = 1 To FontsComboBox.ListCount
        fonts(i) = FontsComboBox.List(i)
    Next
   
End Sub

[свернуть]

[Firetol]

Происходит ошибка в этой строке:
ReDim fonts(1 To FontsComboBox.ListCount)

[вложение удалено администратором]

[Администратор]

У меня работает. Не знаю, почему у вас не работает.

[Firetol]

Перезагрузил компьютер и ошибка перестала появляться. Даже не знаю, что думать.
А так все работает, большое спасибо!

[Администратор]

Я не знаю причины, почему была ошибка.

[Администратор]

Есть ещё такой вариант. Использование программы "Word". Можно подключиться к ворду из экселя и воспользоваться функционалом ворда.
Полученные шрифты не отсортированы по алфавиту, поэтому потребуется сортировка.

Макрос

Sub Макрос2()

    Dim WordApp As Object, font As String, i As Long
   
   
    '1. Запускаем программу "Word" и присваиваем ей имя "WordApp".
        ' Далее в коде будем работать с вордом, используя имя "WordApp".
    Set WordApp = CreateObject(Class:="Word.Application")
   
    '2. Цикл по шрифтам. Не знаю, где эти шрифты находятся в ворде.
    For i = 1 To WordApp.FontNames.Count
   
        '1) Запись шрифта в переменную, чтобы два раза не обращаться к объекту.
            ' Так удобнее, на первый взгляд.
        font = WordApp.FontNames(i)
       
        '2) Есть шрифты, у которых спереди символ "@". Не знаю, что это означает.
            ' Такие шрифты не будем получать.
        If Left(font, 1) <> "@" Then
            ' Запись шрифта в View - Immediate Window.
            Debug.Print font
        End If
       
    Next i
   
    '3. Закрытие программы "Word".
    ' SaveChanges:=False - делается на всякий случай.
        ' Мы не делали изменений, но вдруг какие-то изменения всё-таки произошли; чтобы не было сообщения,
        ' предлагающего сохранить изменения.
    WordApp.Quit SaveChanges:=False
   
End Sub

[свернуть]

[Администратор]

я изменил ответ 6 - адаптировал макрос к экселю - можете запускать макрос из экселя