エクセルでフォントの一覧を作成

Sub macro110702a()
'フォント名と見本一覧を作成

    Sheets.Add
    Cells(1, 1) = "フォント名"
    Cells(1, 2) = "見本"
   
    Dim i As Integer
    Dim str1 As String
     Dim str2 As String
    Dim obj As Object
    str1 = "abcdefghijklmnopqrstuvwxyz"
    str2 = "0123456789"
    Set obj = Application.CommandBars("Formatting"). _
        Controls.Item(1)
   
    For i = 1 To obj.ListCount
        Cells(i + 1, 1) = obj.List(i)
        Cells(i + 1, 2) = str1
        Cells(i + 1, 3) = str2
        Cells(i + 1, 2).Font.Name = obj.List(i)
        Cells(i + 1, 3).Font.Name = obj.List(i)
    Next i
   
End Sub