最近自分の周りでPowerPoint VBAが流行っているようだったので、新しい記事をググったところ、chemiphys氏のブログが更新されていました。

Powerpoint VBAを使おう!

Entry is not found - Powerpoint VBAを使おう!

http://chemiphys.hateblo.jp/entry/2018/09/03/(・・?

Powerpoint VBAやExcelのVBAで遊んでいます。JavaScriptやJScript,HTAに最近はまってます。

PowerPointではフォント選択のコンボボックスからフォントを取得できない問題について書かれていて、確認してみると、たしかにListCountプロパティは「0」になっていて、中身は何も無さそうです。
(余談ですが、コマンドバーの操作をする場合、インデックスで指定するよりアプリケーションのバージョンに依存しないIDで指定することをお薦めします。)

Public Sub Sample01()
  Dim cb As CommandBarComboBox
  
  Set cb = Application.CommandBars.FindControl(Id:=1728) 'フォント
  Debug.Print "ListCount:" & cb.ListCount
End Sub

念のためコマンドバーに追加したフォントコンボボックスを表示させてみましたが、やはり中身はすっからかんです。

Public Sub Sample02()
  With Application.CommandBars.Add(Position:=msoBarPopup, Temporary:=True)
    .Controls.Add Id:=1728, Temporary:=True 'フォント
    .ShowPopup
    .Delete
  End With
End Sub

コマンドバーはOffice 2003以前のレガシーなインターフェースですので、処理ができなくなっていても不思議ではなく、むしろ逆に、コマンドバーからフォントが取得できるExcelやWordの方がおかしいといっても過言ではないのかもしれません。

今のインターフェースであるリボン上の「フォント」コンボボックスから、UI AutomationやMSAAを使ってフォントの一覧を取得することも恐らくできますが、処理が複雑になるため、あまりお薦めはできません。

そこで、コンボボックスから取得するのではない、全く別の方法を考えてみました。

Public Sub ListInstallFonts()
  Dim itm As Object
  Const CSIDL_FONTS = 20
  
  With CreateObject("Shell.Application").Namespace(CSIDL_FONTS)
    For Each itm In .Items
      Debug.Print .GetDetailsOf(itm, 8)
    Next
  End With
End Sub

といっても仕組みは単純で、NameSpaceメソッドでFontsフォルダを取得し、中にあるフォントファイルからGetDetailsOfメソッドでファミリー名を抜き出しているだけです。

上記コードで取得できるのは、あくまでも端末にインストールされているフォントだけで、コンボボックス上で表示されるクラウドフォント(「選択してダウンロード」アイコンが表示されているフォント)は取得できませんが、大体の用途には使用できるかと思います。