フォント フォント総てをシートに書き出す

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][フォント フォント総てをシートに書き出す]
Option Explicit


Sub UseFont()
'****************************************
'フォント総てをシートに書き出す
'****************************************
'対象:PC内にインストールされているフォント
'抽出先:ActiveWorkbook.ActiveSheet
'2009/6/18更新
'プログラムが使用可能なフォントは 256 個という制限があります。
'[このブックで、これ以上新しいフォントは設定できません。]

Dim objcombo As CommandBarComboBox
Dim strFontName As String
Dim intFor As Integer
Dim sht As Worksheet
Dim lngThisRow As Long
Dim Mystr As String

Mystr = "Test"

Set sht = ActiveWorkbook.ActiveSheet
Set objcombo = CommandBars(4).Controls(1)

Application.ScreenUpdating = False

With sht
    .Range("a1:c65536").Clear '@
    .Range("a1").Value = "FontName" 'A
End With

For intFor = 1 To objcombo.ListCount
    strFontName = objcombo.List(intFor)
        With sht
            lngThisRow = .Range("a1").CurrentRegion.Rows.Count + 1 'B
            .Range("a" & lngThisRow).Value = strFontName 'C
            .Range("c" & lngThisRow).Value = Mystr 'D
            If intFor <= 253 Then 'F
                With .Range("c" & lngThisRow).Font 'E
                    .Name = strFontName
                    .Size = 18
                End With
            End If
        End With
Next intFor

Application.ScreenUpdating = True

Set sht = Nothing
Set objcombo = Nothing

'以下でも可能
'.Range(.Cells(1, 1), .Cells(65536, 3)).Clear '@
'.Cells(1, 1).Value = "FontName" 'A
'lngThisRow = .Cells().End(xlUp).Row + 1 'B
'.Cells(lngThisRow, 1).Value = strFontName 'C
'.Cells(lngThisRow, 2).Value = Mystr 'D
'With .Cells(lngThisRow, 3).Font 'E
'Fエクセル自体が使用するフォント数もあるため
End Sub






Production Japan Import Application. Since 1998