Word Макросы: Получить в качестве источника строк список шрифтов

[Svetik]

Подскажите пожалуйста, как на созданной мною форме в поле с выпадающим списком в качестве источника строк получить список шрифтов (который отображается в Word при выборе шрифтов).

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

• Сделал для примера файл, т.к. нужен модуль для сортировки шрифтов, т.к. шрифты возвращаются не по алфавиту.
• Макрос запускайте из VBA, из модуля формы.
• Ворд возвращает ещё шрифты, которые начинаются символом "@". Если вам не нужны они, то нужно внести изменения в макрос.

Код для формы

Private Sub CommandButton1_Click()

    Dim arr(), i As Long
   
    '1. Создание ячеек в массиве "arr".
    ReDim arr(1 To Application.FontNames.Count)
    '2. Запись шрифтов, известных программе "Word", в массив "arr".
    For i = 1 To Application.FontNames.Count Step 1
        arr(i) = Application.FontNames(i)
    Next i
    '3. Сортировка шрифтов по алфавиту (в коллекции "FontNames" шрифты отсортированы
        ' по какому-то другому принципу).
    Call Module1.mySort(arr())
    '4. Копирование данных из массива в комбобокс.
    Me.ComboBox1.List = arr()
   
End Sub

[свернуть]

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

[Svetik]

Замечательно! Большое спасибо! Все хорошо! Если Вас не затруднит, сделайте еще вариант без шрифтов со знаком "@". Я их никогда не использую.

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

Макрос

Private Sub CommandButton1_Click()

    Dim arr(), i As Long, r As Long
   
    '1. Создание ячеек в массиве "arr".
    ReDim arr(1 To Application.FontNames.Count)
    '2. Запись шрифтов, известных программе "Word", в массив "arr".
    For i = 1 To Application.FontNames.Count Step 1
        ' Стили, которые начинаются "@", не берутся.
        If Left(Application.FontNames(i), 1) <> "@" Then
            r = r + 1
            arr(r) = Application.FontNames(i)
        End If
    Next i
    '3. Удаление с конца пустых элементов, которые остались из-за стилей, начинающихся "@".
    ReDim Preserve arr(1 To r)
    '4. Сортировка шрифтов по алфавиту (в коллекции "FontNames" шрифты отсортированы
        ' по какому-то другому принципу).
    Call Module1.mySort(arr())
    '5. Копирование данных из массива в комбобокс.
    Me.ComboBox1.List = arr()
   
End Sub

[свернуть]

[Svetik]

Большое спасибо!