フォントサイズをコンマ台で刻む

ふと、思った。
そういえば、Excelのフォントサイズで、「10.5」ってあるな。

例えば、Ａ１セルのフォントサイズの型を調べてみると、Doubleとある。

なので、小数点を含む設定が可能なのだろう。

1. フォントサイズ　10.4 の場合

Ａ１セルのフォントサイズを、10.4にしてみた。
結果、表示は10.5となった。

しかし内部的には、10.4らしい。

更に確認したところ、
10.6 ⇒ 10.5
10.7 ⇒ 10.5
10.8 ⇒ 11
になったことから、表示は0.5刻みのようだ。

2. フォントサイズ　10.51の場合

Ａ１セルのフォントサイズを、10.51にしてみた。
結果、表示は10.5となった。

イミディエイトウィンドウで表示させても10.5だ。

更に確認したところ、
10.52 ⇒ 10.5
10.53 ⇒ 10.55
になったことから、その桁で5刻みに丸められるようだ。
※ただし、シート側での表示は0.5刻み。

実際、どこまでが限界か確認していないが、現実的に0.01のオーダーで
フォントサイズに変化を付けても、あまり意味がないと思う。なぜなら
きっと、目視では違いが判らないだろうから。

ということで、前々回に作成した「オートシェイプのサイズに合わせて
フォントサイズを調整する」関数について、サイズ調整を0.1刻みに変更
してみた。

↓ 前々回。
infoment.hatenablog.com

Function TextToFitShape(target_shape As Excel.Shape) As Double
    ' テキストの有無確認。無い場合は、Functionを終了する。
        If target_shape.TextFrame2.TextRange.Characters.Text = vbNullString Then
            Exit Function
        End If

    ' オートシェイプのサイズ取得。
    Dim h(1) As Double: h(0) = target_shape.Height
    Dim w(1) As Double: w(0) = target_shape.Width
    
    ' オートシェイプを一旦、文字サイズに合わせてサイズ変更。
        target_shape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
        
    ' 変更後のサイズ取得。
        h(1) = target_shape.Height
        w(1) = target_shape.Width
    
    ' オートシェイプの縦と横、各々の縮小（もしくは拡大）率のうち、
    ' 小さい方を取得（大きい方だと、オートシェイプから食み出る）。
    Dim ρ As Double
        ρ = WorksheetFunction.Min(h(0) / h(1), w(0) / w(1))
    
    ' もとのフォントサイズにρを掛け、目安のフォントサイズを得る。
    Dim FontSize As Double
        FontSize = target_shape.TextFrame2.TextRange.Font.Size * ρ
        
    Dim i As Long
        Do
            ' フォントサイズ仮決め。
            target_shape.TextFrame2.TextRange.Font.Size = FontSize
            
            ' 改めて、オートシェイプを文字サイズに合わせてサイズ変更。
            target_shape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
            
            ' 変更後のサイズを得る。
            h(1) = target_shape.Height
            w(1) = target_shape.Width
            
            ' 縦と横どちらか一方でも元のサイズを越えたら、そこで終了。
            If h(1) > h(0) Or w(1) > w(0) Then
                Exit Do
            
            ' そうでなければ、まだピッタリではない。フォントサイズを１増加。
            Else
                FontSize = FontSize + 0.1
            End If
            
            ' 無限ループ防止。
            i = i + 1: If i >= 100 Then Exit Do
        Loop
        
        ' サイズを越えてから抜けたので、0.1引いて丁度のサイズにする。
        FontSize = FontSize - 0.1
        
        ' オートサイズ解除。
        target_shape.TextFrame2.AutoSize = msoAutoSizeNone
        
        ' オートシェイプを最初の大きさに戻す。
        target_shape.Height = h(0)
        target_shape.Width = w(0)
        
        ' フォントサイズを最終値に変更。
        target_shape.TextFrame2.TextRange.Font.Size = FontSize
        
        ' 戻り値としてフォントサイズを返す。
        TextToFitShape = FontSize
End Function

また一歩、目標に近づけたようです。

参考まで。