ExcelVBAメモ:テキストボックスのサイズに合わせてフォントサイズを自動調整

Excelのテキストボックスは、
AutoSizeプロパティによって、フォントに対するテキストボックスのサイズの自動調整を行う機能はありますが、
セルの「縮小して全体を表示する」ようにテキストボックスのサイズに対してフォントサイズを自動調整することはできません。
(私が知らないだけでしたらすみません。)

本業で、このような処理が必要になったので
テキストボックスのサイズに合わせて自動でフォントサイズを調整する関数を作成してみました。

処理内容は単純で、
AutoSizeでサイズが自動調整させれる状態でフォントのサイズを少しずつ落としていき
自動調整されたテキストボックスのサイズが初期サイズ未満になるまでループするというものです。
…ちょっと力技ですね…w

以下のコードを見ての通り、処理的に遅くなることが予想されます。
使用される場合はご注意を。




Excel VBAコード
'機能:ボタンクリック時処理
Sub btn_Click()
    Dim wRet   As Boolean
On Error GoTo proc_err
    '---------------------------------------------------
    'TextBox1のサイズに合わせて、フォントサイズを自動調整(最大30)
    wRet = AutoFontSizeForTextBox(ActiveSheet.Shapes("TextBox1"), 30)
    '---------------------------------------------------
    GoTo proc_end
proc_err:
proc_end:
End Sub


'機能:テキストボックスのサイズに合わせてフォントサイズを自動調整
'引数:rTxtBox      :対象のテキストボックス
'      vDefFontSize :初期フォントサイズ
'       vAdjustCnt  :調整値(小さいほど精度が上がりますが遅くなります。※0.1未満は不可)
'戻値:成否(True/False)
Public Function AutoFontSizeForTextBox(ByRef rTxtBox As Shape, _
                                     Optional vDefFontSize As Long = -1, _
                                     Optional vAdjustCnt As Double = 0.5) As Boolean
    Dim wRet            As Boolean
    Dim wStr            As String
    Dim wFontSize       As Double
    Dim wLeft           As Double
    Dim wTop            As Double
    Dim wWidth          As Double
    Dim wHeight         As Double
On Error GoTo proc_err
    wRet = True
    Application.ScreenUpdating = False
    '----------------------------------------------------
    With rTxtBox
        '文字列を変数に確保
        wStr = .TextFrame.Characters.Text
        
        'フォントサイズを初期値に設定
        If vDefFontSize > -1 Then
            .TextFrame.Characters.Font.Size = vDefFontSize
        End If
    
        'テキストボックスの文字列と調整値が設定されていない場合は処理しない
        If wStr <> "" And vAdjustCnt >= 0.1 Then
            'テキストボックスの位置・サイズを保持
            wLeft = .Left
            wTop = .Top
            wWidth = .Width
            wHeight = .Height
            .TextFrame.AutoSize = True
            '-------------------------------------------
            '初期フォントサイズを取得
            wFontSize = .TextFrame.Characters(1, Len(wStr)).Font.Size
            '-------------------------------------------
            'テキストボックスに収まるフォントサイズを取得
            Do Until (.Width < wWidth And .Height < wHeight)
                'フォントサイズが1以下になったら終了
                If wFontSize - 1 <= 0 Then Exit Do
                
                '少しずつフォントサイズを小さくする
                .TextFrame.Characters(1, Len(wStr)).Font.Size = wFontSize - vAdjustCnt
                wFontSize = .TextFrame.Characters(1, Len(wStr)).Font.Size
            Loop
            '-------------------------------------------
            '位置・サイズを元に戻す
            .TextFrame.AutoSize = False
            .Height = wHeight
            .Left = wLeft
            .Width = wWidth
            .Top = wTop
        End If
    End With
    '----------------------------------------------------
    GoTo proc_end
proc_err:
    'エラー
    wRet = False
proc_end:
    Application.ScreenUpdating = True
    AutoSizeFont_TextBox = wRet
End Function


コメント
コメントする








    
この記事のトラックバックURL
トラックバック