t-hom’s diary

主にVBAネタを扱っているブログ…とも言えなくなってきたこの頃。

VBA Win32APIを使って、文字列の実描画幅を取得する。

PCのフォントには固定幅のものと可変幅のものがある。

固定幅のフォントは単純に同じ文字数で改行すれば綺麗な矩形になるが、可変幅のフォントでは単純に同じ文字数で改行してもガタガタになる。

f:id:t-hom:20190119014553p:plain

これを概ね揃うようにWin32 APIを使って、文字列の幅を測りながら出力してみようと思う。

きっかけになったのはタイムラインに流れてきたこちらのツイート。


コード

標準モジュールに以下のコードを張り付ける。

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, _
    ByVal nWidth As Long, _
    ByVal nEscapement As Long, _
    ByVal nOrientation As Long, _
    ByVal fnWeight As Long, _
    ByVal IfdwItalic As Long, _
    ByVal fdwUnderline As Long, _
    ByVal fdwStrikeOut As Long, _
    ByVal fdwCharSet As Long, _
    ByVal fdwOutputPrecision As Long, _
    ByVal fdwClipPrecision As Long, _
    ByVal fdwQuality As Long, _
    ByVal fdwPitchAndFamily As Long, _
    ByVal lpszFace As String) As Long
    
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, _
    ByVal lpStr As String, _
    ByVal nCount As Long, _
    lpRect As RECT, _
    ByVal wFormat As Long) As Long

Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const DEFAULT_CHARSET = 1
Private Const OUT_DEFAULT_PRECIS = 0
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const FF_SCRIPT = 64
Private Const DT_CALCRECT = &H400

Function MeasureTextWidth( _
        target_text As String, _
        FONT_NAME As String, _
        Optional font_height As Long = 10) As Long
    
    Dim hWholeScreenDC As Long: hWholeScreenDC _
        = GetDC(0&)
    
    Dim hVirtualDC As Long: hVirtualDC _
        = CreateCompatibleDC(hWholeScreenDC)

    Dim hFont As Long: hFont _
        = CreateFont(font_height, 0, 0, 0, FW_NORMAL, _
            0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, _
            CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _
            DEFAULT_PITCH Or FF_SCRIPT, FONT_NAME)
            
    Call SelectObject(hVirtualDC, hFont)
    
    Dim DrawAreaRectangle As RECT
    Call DrawText(hVirtualDC, target_text, -1, DrawAreaRectangle, DT_CALCRECT)
    
    Call DeleteObject(hFont)
    Call DeleteObject(hVirtualDC)
    Call ReleaseDC(0&, hWholeScreenDC)
    MeasureTextWidth = DrawAreaRectangle.Right - DrawAreaRectangle.Left
End Function

Sub 幅を揃えて出力()
    Const 基準テキスト = "固定幅のフォントは"
    Const 対象テキスト = "固定幅のフォントは単純に同じ文字数で改行すれば綺麗な矩形になるが、可変幅のフォントでは単純に同じ文字数で改行してもガタガタになる。"
    Const FONT_NAME = "MS Pゴシック"
    
    Dim 基準テキストの長さ As Long
    基準テキストの長さ = MeasureTextWidth(基準テキスト, FONT_NAME)
    
    Dim tmpText As String
    tmpText = ""
    Dim i As Long
    For i = 1 To Len(対象テキスト)
        If MeasureTextWidth(tmpText + Mid(対象テキスト, i, 1), FONT_NAME) > 基準テキストの長さ Then
            Debug.Print tmpText
            tmpText = Mid(対象テキスト, i, 1)
        Else
            tmpText = tmpText & Mid(対象テキスト, i, 1)
        End If
    Next
    Debug.Print tmpText
End Sub

メインのプロシージャは「幅を揃えて出力」で、それ以外はほぼWin32APIの処理。
ちなみに64bit版Officeには対応させていない。※面倒くさかったので。。

MeasureTextWidthはテキストとフォント名を与えるとLong型で幅を返す。
※幅の単位は不明だけど、恐らくポイントだと思われる。

そしてメインの「幅を揃えて出力」では、対象テキストを1文字ずつtmpTextにくっつけて、基準となるテキスト幅を超える手前でPrintする処理となっている。

実行結果はイミディエイトウインドウに出力される。(この時点ではイミディエイトウインドウのフォント設定によるので、揃ってない。)
f:id:t-hom:20190119020411p:plain

テキストボックス等に貼り付けて対象フォントをFONT_NAMEと同じものを選択すると、このようにある程度揃う。
f:id:t-hom:20190119020518p:plain

以上

当ブログは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。