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

コード

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

PrivateType RECT
    LeftAsLong
    Top AsLongRightAsLong
    Bottom AsLongEndTypePrivateDeclareFunction GetDC Lib"user32"(ByVal hwnd AsLong)AsLongPrivateDeclareFunction CreateCompatibleDC Lib"gdi32"(ByVal hdc AsLong)AsLongPrivateDeclareFunction SelectObject Lib"gdi32.dll"(ByVal hdc AsLong,ByVal hgdiobj AsLong)AsLongPrivateDeclareFunction DeleteObject Lib"gdi32.dll"(ByVal hObject AsLong)AsLongPrivateDeclareFunction ReleaseDC Lib"user32"(ByVal hwnd AsLong,ByVal hdc AsLong)AsLongPrivateDeclareFunction CreateFont Lib"gdi32"Alias"CreateFontA"(ByVal nHeight AsLong, _ByVal nWidth AsLong, _ByVal nEscapement AsLong, _ByVal nOrientation AsLong, _ByVal fnWeight AsLong, _ByVal IfdwItalic AsLong, _ByVal fdwUnderline AsLong, _ByVal fdwStrikeOut AsLong, _ByVal fdwCharSet AsLong, _ByVal fdwOutputPrecision AsLong, _ByVal fdwClipPrecision AsLong, _ByVal fdwQuality AsLong, _ByVal fdwPitchAndFamily AsLong, _ByVal lpszFace AsString)AsLongPrivateDeclareFunction DrawText Lib"user32"Alias"DrawTextA"(ByVal hdc AsLong, _ByVal lpStr AsString, _ByVal nCount AsLong, _
    lpRect As RECT, _ByVal wFormat AsLong)AsLongPrivateConst FW_NORMAL =400PrivateConst FW_BOLD =700PrivateConst DEFAULT_CHARSET =1PrivateConst OUT_DEFAULT_PRECIS =0PrivateConst CLIP_DEFAULT_PRECIS =0PrivateConst DEFAULT_QUALITY =0PrivateConst DEFAULT_PITCH =0PrivateConst FF_SCRIPT =64PrivateConst DT_CALCRECT =&H400

Function MeasureTextWidth( _
        target_text AsString, _
        FONT_NAME AsString, _Optional font_height AsLong=10)AsLongDim hWholeScreenDC AsLong: hWholeScreenDC _= GetDC(0&)Dim hVirtualDC AsLong: hVirtualDC _= CreateCompatibleDC(hWholeScreenDC)Dim hFont AsLong: 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.LeftEndFunctionSub幅を揃えて出力()Const基準テキスト ="固定幅のフォントは"Const対象テキスト ="固定幅のフォントは単純に同じ文字数で改行すれば綺麗な矩形になるが、可変幅のフォントでは単純に同じ文字数で改行してもガタガタになる。"Const FONT_NAME ="ＭＳ Ｐゴシック"Dim基準テキストの長さ AsLong基準テキストの長さ = MeasureTextWidth(基準テキスト, FONT_NAME)Dim tmpText AsString
    tmpText =""Dim i AsLongFor i =1ToLen(対象テキスト)If MeasureTextWidth(tmpText +Mid(対象テキスト, i,1), FONT_NAME)>基準テキストの長さ Then
            Debug.Print tmpText
            tmpText =Mid(対象テキスト, i,1)Else
            tmpText = tmpText &Mid(対象テキスト, i,1)EndIfNext
    Debug.Print tmpText
EndSub

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

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

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

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

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

以上