BDFフォントビューアをExcel VBAで作った

BDFフォントとは

BDFフォントとは、Glyph Bitmap Distribution Formatで定義した、ビットマップフォントのことである。

最新のバージョンはVersion 2.2だが、この記事で対象とするBDFフォントは一つ前のVersion 2.1 。

ここでは、Glyph Bitmap Distribution Format(BDF)そのものの説明は省くため、中身を知りたい方は、以下のURLを参照のこと。

どこで使うの

Wikipediaによると、
『1988年にXコンソーシアムがX Windowスクリーンフォントの標準としてBDF 2.1を採用した』とあるが、今やWindows、Linux、MacもOpentypeフォント(OTF)やTruetypeフォント(TTF)が主流のため、使われる機会は少ないと思われる。

しかし、現在でも、マイコン等でメモリが少ないながらプロポーショナルフォントを使いたい場合に、BDFフォントが使われることがある。CircuitPythonにてこちらのライブラリを使うと、直接 BDFファイルパスを指定して、ディスプレイに文字を描画できる。

また、BDFフォントからグリフ（文字のビットパターン）を抽出して、使用する場合もある。

入手方法

BDFフォントはネットで検索すると、簡単に見つけることができる。
また、TruetypeフォントからBDFフォントへ変換するWebサイトやユーティリティコマンドなどもある。
実際に使用する場合は、入手したBDFフォントや変換元のTruetypeフォントのライセンスに基づく必要がある。

今回の記事では、有名なBaskervilleフォントのSemiBold Italic体を、（18pt, 96dpiの）BDFに変換したフォントBaskerville-SemiBoldItalic-06.bdfを使用した。

Digitized data copyright © 2000 Agfa Monotype Corporation. All rights reserved. Monotype Baskerville™ is a trademark of Agfa Monotype Corporation.

BDFをちょっとだけ解説

（単なるテキストファイルのため、）BDFファイルをテキストエディタで開き、フォントの大きさを確認する。

• FONTBOUNDINGBOX 59 34 -15 -9

このフォントのバウンディングボックスは59x34ピクセル、原点は(-15, -9)。これを図で表すと以下の通り（■が原点）。
（プロポーショナルフォントのため、実際のグリフエリアは文字ごとに異なる）

このフォントはかなり横幅が広いし原点オフセットが深い。おそらく、イタリック体のため文字が相当斜めっていると想定して、ファイル内の最大幅のフォントを調べると、ギリシャ数字のⅧだった。

逆オフセットの最大は、U+2017（Double Low Line）（文字の原点が(-15, -8)）。

次文字の原点がフォントバウンディングボックスの原点に重なっているため、一つ前の文字を修飾すると考えられる。TTFで確認したところ、実際にそうであった。

• CHARS 1669

このファイルには、全部で1,669個の文字情報が定義されていることが分かる。

小文字iの情報を見てみる。

• 小文字iの情報

STARTCHAR 0069
ENCODING 105
SWIDTH 333 0
DWIDTH 8 0
BBX 7 16 1 0
BITMAP
0C
0E
0C
00
00
00
38
F8
B8
38
70
70
60
EC
F8
70
ENDCHAR

• BBX 7 16 1 0　（小文字iのグリフエリア）

グリフのサイズは7x16ピクセル、原点からのオフセットは(1, 0)。
これを図で表すと以下の通り（■がこの文字の原点）。

• DWIDTH 8 0

小文字iのデバイス幅（次に続く文字の原点までのオフセット）は(8, 0)。

以上の情報から、小文字iのレンダリングは、以下のようになる。
（フォントのバウンディングボックスに重ねる。■が次に続く文字の原点）

• 次にjを置いてみると、

iと、続くjのグリフが重なっていることが分かる。

よって、文字をレンダリングするときは、最初に全体の描画エリアを計算して背景色で塗りつぶしてから、1のピクセルを前景色で塗る操作が必要。0の度に背景色に塗ると、前の文字を壊すことになる。

• 等幅フォントに改造できる

すべての文字のDWIDTHプロパティを、同じ値で統一すると、それは「等幅フォント」となる。更新したBDFファイルをTTFファイルに変換するツールを通せば、お気に入りのフォントを使った等幅フォントファイルを作ることが可能だ。

BDFフォントビューア

Excelで作るBDFフォントビューアを見ていく。VBAコードはこの後に掲示する。

このVBAには、3つのメインプロシジャと、いくつかの内部プロシジャがある。

#	プロシジャ	機能
1	BDF_Info	BDFファイルを入力して、2つのシートを生成する。 ・シート1）BDFの全体情報と各文字のグリフ情報 ・シート2）定義されているすべての文字のビットマップイメージ
2	makeHex	指定された文字のビットマップ情報から、16進数のデータ列を生成する
3	makeGlyph	指定された文字のビットマップ情報から、ExcelのShapeを使った文字グリフ（ビットマップ相当）を生成する

（内部プロシジャの説明は省略する）

各プロシジャの使い方を説明する。

1.　BDF_Info

マクロからBDF_Infoを実行する。PCの性能や文字数に大きく依存するが、1669文字で7〜8秒ほどで2つのシートが追加される。（1文字当たり6〜8ミリ秒）

シート1）BDFの全体情報と各文字のグリフ情報

一切フォーマライズしていないため、体裁等は必要により調整してほしい。
文字ごとの情報は一覧化しているので、テキストエディタで見るよりは、扱いやすいはず。

シート2）定義されているすべて文字のビットマップイメージ

定義されているすべての文字のイメージを、定義順に縦に出力する。
Excelで表示縮小率を30%ほどにすると、文字のイメージがよく分かる。
（■がバウンディングボックスの原点、■がその文字の原点、■が次に続く文字の原点を示す。バウンディングボックスの原点と文字の原点が同じ場合は■は見えない）

2.　makeHex

上の文字イメージ内の「任意のセルをクリックして選択」した上で、マクロからmakeHexを実行する。

すると、一瞬でイメージの右側に16進数のデータを生成する。

最初からすべての文字について、16進数データを生成したい場合の方法については、VBAコードのところで説明する。
（その場合は多少は処理時間が伸びるため、16進数データが必要な文字だけを抜き出したBDFファイルを作ることをお勧めする）

3.　makeGlyph

makeHexと同様に、「文字イメージ内の任意のセルをクリックして選択」した上で、マクロからmakeGlyphを実行する。

すると、秒で右側にイメージを生成する。

描画するピクセルの色は、Excelに設定されている「既定の図形の塗りつぶしの色」である。色を変更して「既定の図形に設定」すると、それ以降の描画に反映される。

Xのピクセルに対応した数だけShapeオブジェクトを生成し、グループ化している。よって、グループオブジェクトの幅と高さは文字ごとに異なる。

1文字だと秒で生成するが、すべての文字となると、何十万ものピクセル（Shapeオブジェクト）を生成するため、何時間もかかると思われる。
（Shapeオブジェクト数が1000を超える辺りから遅さを感じるが、Shapeオブジェクト数に比例ではなく、指数的に遅くなっていくようだ）。

VBAコード

以下のコード（約300行）をExcelの標準モジュールに貼り付ける。
最初から「すべての文字について16進数データを生成したい」場合は、⭐️3行目の
withHexData定数をTrueにする（その場合、1文字当たり10ミリ秒ほどの処理時間となる）。

ちなみに、このコードは、Excel for Windows、Excel for Mac どちらでも実行可能である。

VBAコード（ここをクリック）

Option Explicit

Const withHexData = False '⭐️
Global gCancel As Boolean
 
Dim filePath As Variant
Dim bdf As Variant
Dim font_bbx(1 To 4) As Long
Dim gly(0 To 511, 0 To 511) As String
Dim numChars As Long

Sub BDF_Info()
    gCancel = False
    If Not setBDF() Then Exit Sub
     
    Dim startTimer: startTimer = Timer
    Application.ScreenUpdating = False
    
    Dim Info As Worksheet
    Set Info = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    
    Cells(1, 1) = "File Path: ": Cells(1, 2) = filePath
    Dim r As Long, row As Long: row = 2
    Dim prop As Boolean: prop = False
    For r = 1 To 1000
        Dim v As Variant: v = Split(CStr(bdf(r, 1)), " ")
        Select Case v(0)
        Case "STARTFONT"
            Cells(row, 1) = "BDF File Version: ": Cells(row, 2) = v(1)
            row = row + 1
        Case "FONT"
            Cells(row, 1) = "Font: ": Cells(row, 2) = Mid(CStr(bdf(r, 1)), 6)
            row = row + 1
        Case "SIZE"
            Cells(row, 1) = "Size: ": Cells(row, 2) = v(1) & "pt"
            Cells(row, 3) = "X: " & v(2) & "dpi": Cells(row, 4) = "Y: " & v(3) & "dpi"
            row = row + 1
        Case "FONTBOUNDINGBOX"
            Cells(row, 1) = "Bounding Box: "
            Cells(row, 2) = "Width: " & v(1) & "px": Cells(row, 3) = "Height: " & v(2) & "px"
            Cells(row, 4) = "LeftBottom X: " & v(3) & "px": Cells(row, 5) = "Y: " & v(4) & "px"
            Dim n As Long: For n = 1 To 4: font_bbx(n) = CDbl(v(n)): Next
            row = row + 1
        Case "STARTPROPERTIES"
            Cells(row, 1) = "Number of Properties: ": Cells(row, 2) = v(1)
            row = row + 1
            prop = True
        Case "ENDPROPERTIES"
            prop = False
        Case "CHARS"
            Cells(row, 1) = "Number of Glyph: ": Cells(row, 2) = v(1)
            numChars = CLng(v(1))
            row = row + 1
            Exit For
        Case Else
            If prop Then
                Cells(row, 2) = v(0): Cells(row, 3) = Mid(CStr(bdf(r, 1)), Len(v(0)) + 2)
                row = row + 1
            End If
        End Select
    Next
    
    Range(Cells(row, 1), Cells(row, 11)) = Array("#", "Start Char", "Encoding", "Scalable Width X", "Y", "Device Width X", "Y", "Bounding Box Width", "Height", "X", "Y")
    row = row + 1
    Dim done As Boolean: done = True
    Dim gy As Long: gy = 1
    Dim save_r As Long: save_r = r
    Dim m As Long
    
    Do While done
        v = Split(CStr(bdf(r, 1)), " ")
        Select Case v(0)
        Case "STARTCHAR"
            Cells(row, 1) = gy: Cells(row, 2) = "'" & v(1)
        Case "ENCODING"
            Cells(row, 3) = v(1)
        Case "SWIDTH"
            Cells(row, 4) = v(1): Cells(row, 5) = v(2)
        Case "DWIDTH"
            Cells(row, 6) = v(1): Cells(row, 7) = v(2)
        Case "BBX"
            Cells(row, 8) = v(1): Cells(row, 9) = v(2): Cells(row, 10) = v(3): Cells(row, 11) = v(4)
        Case "ENDCHAR"
            row = row + 1
            gy = gy + 1
        Case "ENDFONT"
            done = False
        Case Else
            'pass
        End Select

        r = r + 1
    Loop
    r = save_r + 1
     
    'Glyph
    Dim glyph As Worksheet
    Set glyph = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    With Cells
        .ColumnWidth = 1 'x: 12px
        .RowHeight = 12   'y: 12px
    End With
    
    Dim x As Long, y As Long, width As Long, height As Long, offset_x As Long, offset_y As Long
    Dim d_offset_x As Long, d_offset_y As Long
    Dim status As Long: status = 0    '0: ENCODING,  1:DWIDTH, 2: BBX, 3: BITMAP, 4: hex_data
    gy = 1: row = 1: done = True
    Do While done And Not gCancel '⭐️⭐️
        v = Split(CStr(bdf(r, 1)), " ")
        If v(0) = "ENDFONT" Then
            done = False
        ElseIf status = 0 And v(0) = "ENCODING" Then
            Cells(row, 1) = "#" & gy:  Cells(row, 9) = Chr(v(1))
            Cells(row, 4) = "U+" & Right("0000" & Hex(Val(v(1))), 4)
            Rows(row).RowHeight = 20
            Application.StatusBar = Cells(row, 1)
            gy = gy + 1
            row = row + 1
            status = 1
        ElseIf status = 1 And v(0) = "DWIDTH" Then
            d_offset_x = v(1): d_offset_y = v(2)
            status = 2
        ElseIf status = 2 And v(0) = "BBX" Then
           'Cells(row - 1, 10) = bdf(r, 1)
            width = v(1): height = v(2): offset_x = v(3): offset_y = v(4)
            x = Application.WorksheetFunction.Max(offset_x - font_bbx(3), 0)
            y = Application.WorksheetFunction.Max(font_bbx(2) + font_bbx(4) - height - offset_y, 0)
            status = 3
        ElseIf status = 3 And v(0) = "BITMAP" Then
            For n = 0 To font_bbx(2) - 1: For m = 0 To font_bbx(1) - 1: gly(n, m) = ".": Next: Next
            status = 4
        ElseIf status = 4 And v(0) = "ENDCHAR" Then
            Call drawGlyph(row, font_bbx, offset_x, offset_y, d_offset_x, d_offset_y)
            status = 0
            GoTo continue
            
        ElseIf status = 4 Then
            x = Application.WorksheetFunction.Max(offset_x - font_bbx(3), 0)
            Dim length As Long: length = Len(v(0))
            Dim bit(0 To 511) As Integer
            For n = 0 To length - 1
                Dim b As Long: b = Val("&H" & Mid(v(0), n + 1, 1))
                For m = 0 To 3
                    bit(n * 4 + m) = IIf((b And 8) <> 0, 1, 0)
                    b = b * 2 'b <<= 2
                Next
            Next
            For n = 0 To width - 1
                gly(y, x + n) = IIf(bit(n) = 1, "X", ".")
            Next
            y = y + 1
        End If
continue:
        r = r + 1
    Loop
    
    ActiveWindow.DisplayGridlines = False
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    Dim duration: duration = Timer - startTimer
    Debug.Print "Toatl Time: " & Format(duration, "0.000") & "s, per char: " & Format(duration / numChars, "0.000") & "s, chars: " & numChars
End Sub

Private Sub drawGlyph(row As Long, font_bbx, offset_x As Long, offset_y As Long, d_offset_x As Long, d_offset_y As Long)
    Dim x As Long: x = 1 - font_bbx(3)
    Dim y As Long: y = row + font_bbx(2) + font_bbx(4) - 1
    Cells(y, x).Interior.Color = 65535 'yellow
    Cells(y - offset_y, x + offset_x).Interior.Color = 5296274 'green
    Cells(y + d_offset_y, x + d_offset_x).Interior.Color = 49407 'orange

    Range(Cells(row, 1), Cells(row + font_bbx(2) - 1, 1 + font_bbx(1) - 1)) = gly
    
    If withHexData Then
       'Dim start_cell As Range: Set start_cell = Cells(row + 1, font_bbx(1) + 2)
       'Dim start_x As Long: start_x = start_cell.Left
       'Dim start_y As Long: start_y = start_cell.Top
        Call subHex(row, CLng(font_bbx(1)), CLng(font_bbx(2)))
       'Call plotGlyph(start_x, start_y, font_bbx, offset_x, offset_y, d_offset_x, d_offset_y)
    End If
    
    row = row + font_bbx(2)
End Sub

Private Sub subHex(Optional aRow As Long = 0, Optional aWidth As Long = 0, Optional aHeight As Long = 0)
    Dim r As Long, c As Long, s As String
    Dim st(0 To 511, 0 To 0) As String
    Dim w As Long: w = Int((aWidth + 7) / 8)
    Dim b As Long, d(0 To 63) As Long
    For r = 0 To aHeight - 1
        Erase d: s = ""
        For c = 0 To aWidth - 1
             If Cells(r + aRow, c + 1) <> "." Then
                b = &H80 / (2 ^ (c Mod 8))
                d(Int(c / 8)) = d(Int(c / 8)) Or b
             End If
        Next
        For c = 0 To w - 1
            s = s & "0x" & Right("00" & Hex(d(c)), 2) & ", "
        Next
        st(r, 0) = s
    Next
    Range(Cells(aRow, aWidth + 10), Cells(aRow + aHeight - 1, aWidth + 10)) = st
End Sub
  
Sub makeHex()
    Application.ScreenUpdating = False
    Dim row As Long, r As Long, c As Long, width As Long, height As Long
    r = ActiveCell.row
    c = 1: Do While Len(Cells(r, c)) = 1: c = c + 1: Loop
    width = c - 1: c = 1
    Do While Len(Cells(r, c)) = 1: r = r - 1: Loop
    r = r + 1: row = r
    Do While Len(Cells(r, c)) = 1: r = r + 1: Loop
    height = r - row
    'Cells(row, 1).Select
    Call subHex(row, width, height)
    Application.ScreenUpdating = True
End Sub

Sub makeGlyph()
    Application.ScreenUpdating = False
    Dim row As Long, r As Long, c As Long, width As Long, height As Long
    r = ActiveCell.row
    c = 1: Do While Len(Cells(r, c)) = 1: c = c + 1: Loop
    width = c - 1: c = 1
    Do While Len(Cells(r, c)) = 1: r = r - 1: Loop
    r = r + 1: row = r
    Do While Len(Cells(r, c)) = 1: r = r + 1: Loop
    height = r - row
    'Cells(row, 1).Select
    
    Dim start_cell As Range: Set start_cell = Cells(row + 1, width + 2)
    Dim start_x As Long: start_x = start_cell.Left
    Dim start_y As Long: start_y = start_cell.Top

    Const one_dot As Double = 1 / 72
    Dim sh() As Variant, n As Long: n = 0
    ReDim sh(width * height)
    For r = 0 To height - 1
        For c = 0 To width - 1
             If Cells(r + row, c + 1) <> "." Then
                ActiveSheet.Shapes.AddShape(msoShapeOval, start_x + c, start_y + r, one_dot, one_dot).Select
                Selection.ShapeRange.Line.Visible = msoFalse
                Selection.ShapeRange.Fill.Visible = msoTrue
                sh(n) = Selection.Name
                n = n + 1
             End If
        Next
    Next
    If n > 0 Then
        ActiveSheet.Shapes.Range(sh).Select
        Selection.ShapeRange.Group.Select
    End If
    Application.ScreenUpdating = True
End Sub

Private Sub plotGlyph(start_x As Long, start_y As Long, font_bbx, offset_x As Long, offset_y As Long, d_offset_x As Long, d_offset_y As Long)
    Const one_dot As Double = 1 / 72
    Dim sh() As Variant
    ReDim sh(font_bbx(1) * font_bbx(2))
    Dim x As Long, y As Long, n As Long: n = 0
    For y = 0 To font_bbx(2) - 1
        For x = 0 To font_bbx(1) - 1
            If gCancel Then Exit Sub
            If gly(y, x) <> "." Then
                ActiveSheet.Shapes.AddShape(msoShapeOval, start_x + x, start_y + y, one_dot, one_dot).Select
                Selection.ShapeRange.Line.Visible = msoFalse
                Selection.ShapeRange.Fill.Visible = msoTrue
                sh(n) = Selection.Name
                n = n + 1
            End If
        Next
    Next
    If n > 0 Then
        ActiveSheet.Shapes.Range(sh).Select
        Selection.ShapeRange.Group.Select
    End If
End Sub

Private Function setBDF() As Boolean
    setBDF = False
    If Application.OperatingSystem Like "*Mac*" Then
        filePath = Application.GetOpenFilename()
    Else
        filePath = Application.GetOpenFilename(filefilter:="BDFファイル(*.bdf),*.bdf")
    End If
    If filePath = False Then Exit Function
             
    Dim bdfBook As Workbook, maxRow As Long
    Set bdfBook = Application.Workbooks.Open(fileName:=filePath, ReadOnly:=True, Format:=5)
    maxRow = Cells(1, 1).SpecialCells(xlCellTypeLastCell).row
    bdf = Range(Cells(1, 1), Cells(maxRow, 1))
    
    bdfBook.Close savechanges:=False
    setBDF = True
End Function

エラーチェック等は特に行っていないため、矛盾があるBDFファイルやBDF以外のファイルを入力したときの動作は保証できない。マクロエラーが発生して停止するだけと思われる。

改造のヒント

1) 処理中ダイアログ

上のコードは、Excelウィンドウの左下（ステータスエリア）に、処理中の文字数を表示するものの、処理中のダイアログを表示しないため、もし、日本語フォントのように、文字数が万オーダーの場合、Excelが無反応となる（が、処理が終われば表示する）。（OSからExcelが無反応だと警告を受けるが、何も触らず気長に待てばよい）

ユーザフォームを使って処理中ダイアログを作成し、プログレスバーなどで進捗を示すのが、ユーザフレンドリーだ。
一番処理時間を要すループ処理は、コードの⭐️⭐️108行目である。gCancelグローバル変数がTrueとなったらループから抜けて処理を打ち切るようにしてある。

処理中のダイアログに「Cancel」ボタンを用意する場合は、gCancelグローバル変数をTrueにすることで、キャンセル処理を簡単に実装できる。

2) グリフのビットマップ

makeGlyphは1ピクセルづつExcelのShapeオブジェクトを生成している。そのため、すべての文字のグリフを生成するには、膨大な時間を要することになり、非現実的である。
Excel for Windowsであれば、Win32APIを使って、ネイティブにビットマップを描画することで、劇的に性能を改善できると思われる（未検証）。

3) イメージデータのカラー化

現在は、白黒の二値であるが、セルの文字色や背景色を使って、カラー化した16進データを生成することも可能である。同様に、グリフ（ピクセルイメージ）をカラー化することも可能である（処理性能は別とすれば）。

マイコンで使用するLCDなどは、16ビットカラーだったりするので、480x240程度のサイズなら実用範囲内の性能は出せると思われる（未検証）。

裏技

makeHex、makeGlyphは、元のBDFファイルとは関係なく、クリックされたセルの位置からビットマップの矩形サイズを求めているため、手作業で作ったイメージであっても、ちゃんと動作する。

下記の図は、I e f i lと (space)のビットマップをコピーして、原点セルを目印に自分で並べたものである。

上のスクショから、手作りのイメージに対しても、makeHexとmakeGlyphが機能していることを見ていただけると思う。

以上

何かの参考になれば幸甚である。