テキストボックスのサイズに合わせて、中の文字サイズを変更する

昨日、テキストボックスのサイズに合わせて、既存機能で中の文字サイズを変更しようとしたが出来なかった。
infoment.hatenablog.com

無いものは仕方ない、作るとしよう。

作戦としては、こんな感じだ。

1. テキストボックスの大きさを一旦、文字の大きさピッタリにする（自動）。
2. フィット前後の比率から、文字の大きさ（仮）を得る。
3. 文字の大きさ（仮）とテキストボックスを、少しずつ大きくする（ループ）。
   ※テキストボックスの大きさは、文字の大きさに合わせて自動変更。
4. テキストボックスが元の大きさを超えた時点でループ終了。
5. 文字の大きさを決定値に変更。テキストボックスの大きさを元に戻す。

実際に作成したコードがこちら。
何かに使えるかもしれないので、文字の大きさ（決定）を戻り値とする。

Function TextToFitShape(target_shape As Excel.Shape) As Long
    ' テキストの有無確認。無い場合は、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 Long
        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 + 1
            End If
            
            ' 無限ループ防止。
            i = i + 1: If i >= 100 Then Exit Do
        Loop
        
        ' サイズを越えてから抜けたので、１引いて丁度のサイズにする。
        FontSize = FontSize - 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

確認した結果が ↓ こちら。

割と、良い感じになりました。

参考まで。