最近自分の周りでPowerPoint VBAが流行っているようだったので、新しい記事をググったところ、chemiphys氏のブログが更新されていました。
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メソッドでファミリー名を抜き出しているだけです。
上記コードで取得できるのは、あくまでも端末にインストールされているフォントだけで、コンボボックス上で表示されるクラウドフォント(「選択してダウンロード」アイコンが表示されているフォント)は取得できませんが、大体の用途には使用できるかと思います。
この記事へのコメントはありません。