Yazı Tiplerini Listele - Microsoft Excel

Windows/Fonts klasöründe bulunan yazı tiplerini A sütununa listeler. Listeleme esnasında hücrenin yazı tipi de hücrenin içinde yazan yazı tipiyle aynı olur.

Option Explicit

Sub YaziTipleriniListele()
    '--------------------------------------------------
    'Değişkenler
    '--------------------------------------------------
    Dim yaziTipleri As Variant
    Dim x           As Integer
    
    '--------------------------------------------------
    'Değişkenlere atama yap.
    '--------------------------------------------------
    x = 1
    Set yaziTipleri = Application.CommandBars.FindControl(ID:=1728)
    
    
    On Error Resume Next
    
    '--------------------------------------------------
    'Yazı tiplerini biçimlendirerek listele.
    '--------------------------------------------------
    Do
        Cells(x + 1, 1) = yaziTipleri.List(x)
        Cells(x + 1, 1).Font.Name = yaziTipleri.List(x)

        If Err Then Exit Do
        x = x + 1
    Loop
    
    On Error GoTo 0
    
    '--------------------------------------------------
    'Tablo başlığını ve biçim ayarlarını yap.
    '--------------------------------------------------
    Range("A1") = "Yazı Tipleri Listesi " & "(" & x - 1 & ")"
    
    With Range("A1")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Name = "Arial"
        .Font.FontStyle = "Bold"
        .Font.Size = 10
        .Font.ColorIndex = 5
        .Interior.ColorIndex = 15
    End With
    
    '--------------------------------------------------
    'Sütun genişliğini ayarla ve değişkenleri temizle.
    '--------------------------------------------------
    Columns("A:A").EntireColumn.AutoFit
    
    Set yaziTipleri = Nothing
End Sub