フォントサイズが必要以上に小さくなってしまう

実現したいこと

文字数の少ないデータを初期値に近いフォントサイズで表示したい

前提

ハガキの宛名面をレポートで作成しています。テキストボックスは他フィールドの有無などの条件によって高さ・幅・フォントサイズ等が変更されるようなコードを記述しています。
以前はデータの文字数によってフォントサイズを変更していたのですが、字詰めフォントを使用すると、全角が多いデータだとテキストボックスにぴったり収まるが、字詰めが多いデータだとスキマが多く発生してしまうという問題が起こっていました。この問題についてこちらで質問したところ、自動で文字を縮小してくれるコード（左記リンクのコードの改良版）を掲載しているサイトを紹介され、導入してみました。

発生している問題・エラーメッセージ

文字数の少ないデータが表示される時、テキストボックスの幅・高さ共にかなり余裕があるように見えるのに、フォントサイズが大幅に縮小してしまいます。
実際の違いがこんな感じです↓。左側が下記のコードを実行したもので、デバッグしてフォントサイズを確認したところ、17でした。右側が文字数でフォントサイズを調整していたレポートのコードを実行したもので、画像の場合はフォントサイズが22です。

該当のソースコード

Option Compare Database
Option Explicit

Enum emVTextAlign
    Top = 0
    Center = 1
    Bottom = 2
End Enum

Public Sub AutoFontSize(Ctr As Control, IniFontSize As Integer, Optional VTextAlign As emVTextAlign = 0)
    Const MinFontSize = 10 '最小のフォントサイズ
    Const d = 20 'うまく収まらずに改行されてしまう場合はここの数値を増やす
    Dim rpt As Report, Str As String, W As Long
    Dim arStr, i As Integer, H As Long, L As Integer
    Set rpt = CodeContextObject
     
With rpt
    If Ctr.ControlType = acTextBox Then
        Str = Ctr.Text  'ここでエラーが出る場合は、Str = Nz(Ctr.Value,"")
    ElseIf Ctr.ControlType = acLabel Then
        Str = Ctr.Caption
    Else
        Exit Sub
    End If
    If Str = "" Then Exit Sub
     
    .FontName = Ctr.FontName
    If Ctr.Vertical Then
        W = Ctr.Height - d
        H = Ctr.Width - d
        If InStr(1, .FontName, "@") = 0 Then
            .FontName = "@" & .FontName
        Else
            .FontName = Mid(.FontName, 2)
        End If
    Else
        W = Ctr.Width - d
        H = Ctr.Height - d
    End If
     
    arStr = Split(Str, vbCrLf, -1, vbBinaryCompare)
    L = UBound(arStr)
    Str = arStr(0)
    For i = 1 To L
        If .TextWidth(arStr(i)) > .TextWidth(Str) Then Str = arStr(i)
    Next
     
    .ScaleMode = 1
    If Ctr.FontBold = 1 Then .FontBold = True
    .FontSize = IniFontSize
    Do Until rpt.FontSize = MinFontSize
        If W > .TextWidth(Str) Then
            Exit Do
        End If
        .FontSize = .FontSize - 1
    Loop
     
    Do Until rpt.FontSize = MinFontSize
        If H > .TextHeight("A") * (L + 1) + Ctr.LineSpacing * L Then
            Exit Do
        End If
        .FontSize = .FontSize - 1
    Loop
    Ctr.FontSize = .FontSize
     
     
    If VTextAlign = emVTextAlign.Top Then Exit Sub
     
    H = .TextHeight("A") * (L + 1) + Ctr.LineSpacing * L
    Select Case VTextAlign
    Case emVTextAlign.Center
        If Ctr.Vertical Then
            Ctr.RightMargin = (Ctr.Width - H) / 2
        Else
            Ctr.TopMargin = (Ctr.Height - H) / 2
        End If
    Case emVTextAlign.Bottom
        If Ctr.Vertical Then
            Ctr.RightMargin = Ctr.Width - H
        Else
            Ctr.TopMargin = Ctr.Height - H
        End If
    End Select
 
End With
 
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Compare Database
Option Explicit

Private Sub 詳細_Format(Cancel As Integer, FormatCount As Integer)

    Const cm As Integer = 567 'twipsをcm表記
    
    Dim txtW As Long 'テキスト幅
    Dim txtboxW As Long 'テキストボックス幅
    Dim checkCharacter As String
    
    checkCharacter = "一" 'テキスト幅調査用の例字

'中略

    Dim company_FontSize As Integer '社名の基準フォントサイズ
    Dim company_Width As Integer '社名の基準テキストボックス幅
    
    Dim cFS As Integer '自動調節後フォントサイズを一番小さい方に合わせる
    Dim cFS1 As Integer '社名1の自動調節後フォントサイズ
    Dim cFS2 As Integer '社名2の自動調節後フォントサイズ
    Dim cFS3 As Integer '社名3の自動調節後フォントサイズ

        company_FontSize = 22
        company_Width = 1 * cm
        
        AutoFontSize 社名1, company_FontSize
        社名1.Width = company_Width
        社名1.Top = 1.5 * cm
        社名1.Height = 9.9 * cm
        
        AutoFontSize 社名2, company_FontSize
        社名2.Width = company_Width
        社名2.Top = 1.8 * cm
        社名2.Height = 9.6 * cm
        
        AutoFontSize 社名3, company_FontSize
        社名3.Width = company_Width
        社名3.Top = 2.1 * cm
        社名3.Height = 9.3 * cm
        
        cFS1 = 社名1.FontSize
        cFS2 = 社名2.FontSize
        cFS3 = 社名3.FontSize
        
        If cFS1 < cFS2 Then

            If cFS1 < cFS3 Then

                cFS = cFS1

            Else

                cFS = cFS3

            End If

        ElseIf cFS2 < cFS3 Then

                cFS = cFS2

        Else

            cFS = cFS3

        End If
    
        社名1.FontSize = cFS
        社名2.FontSize = cFS
        社名3.FontSize = cFS

        With Me.社名1
        
            Me.FontName = .FontName
            Me.FontSize = .FontSize
            txtboxW = .Width
            txtW = Me.TextWidth(checkCharacter)
            .RightMargin = (txtboxW - txtW) / 2
            
        End With

        With Me.社名2
        
            Me.FontName = .FontName
            Me.FontSize = .FontSize
            txtboxW = .Width
            txtW = Me.TextWidth(checkCharacter)
            .RightMargin = (txtboxW - txtW) / 2
            
        End With
        
        With Me.社名3
        
            Me.FontName = .FontName
            Me.FontSize = .FontSize
            txtboxW = .Width
            txtW = Me.TextWidth(checkCharacter)
            .RightMargin = (txtboxW - txtW) / 2
            
        End With
        
        If Trim(Nz(社名2, "")) = "" Then

            社名1.Left = 3.5 * cm
            社名1.TextAlign = 4

        ElseIf Trim(Nz(社名3, "")) = "" Then
         
            社名1.Left = 3.9 * cm
            社名1.TextAlign = 0

            社名2.Left = 3.1 * cm
            社名2.TextAlign = 3
            
        Else
        
            社名1.Left = 4.4 * cm
            社名1.TextAlign = 0
            
            社名2.Left = 3.5 * cm
            社名2.TextAlign = 0

            社名3.Left = 2.6 * cm
            社名3.TextAlign = 3
           
        End If

おおまかなコードの説明としては、社名1～3のテキストボックスそれぞれで標準モジュールの関数を用いて自動でフォントサイズを決定、Top、Width、Heightを設定します。次に各テキストボックスのフォントサイズを比較し、社名1～3の中で一番小さいフォントサイズを採用し代入。その次にWith～でテキストボックスの右側に余白を設定し、テキストボックスの中央に文字が配置されるように調整、最後に社名1～3にデータが入っているかによって、テキストボックスの左位置を変更しています。

試したこと

テキストボックスの設定に問題があるのかと思い、Width等の値を変更してみましたが、フォントサイズは変わりませんでした。

補足情報（FW/ツールのバージョンなど）

Microsoft Access2019

pecmm

2023/09/07 08:42 編集

はみ出さない最大のフォントサイズを計算しているのが『.FontSize = .FontSize - 1』の2箇所と思われるのでループ打ち切り条件の『W > .TextWidth(Str)』や『H > .TextHeight("A") * (L + 1) + Ctr.LineSpacing * L』の各々の値を細かくデバッグ表示してみて、どこで想定より小さくなっているか？どこか変な値がないか？などを確認すると問題の切り分けが出来るかもしれません

sazi

2023/09/07 09:02 編集

コードの内容については、ここで質問されるより、紹介したサイトで質問した方が良いのではないでしょうか？ hatenaさんは、ここのサイトには比較的頻繁に訪れられますので、このままで回答が付くかもしれませんが。そもそも、hatenaさんの回答が中々つかなかったから、取りあえず紹介したんですけどね。

退会済みユーザー

2023/09/07 23:35

pecmmさん有意な回答がつくまではデバッグを重ねて調整してみようと思います。 saziさんサイトで質問しようとも考えたのですが、複数箇所に投稿するとテラテイルの規約違反だと咎めてくる方が数名いらっしゃいますので二の足を踏んでおりました。あちらのサイトでも質問してみましたのでしばらく回答待ちしたいと思います。良いサイトを紹介していただきありがとうございました。

hatena19

2023/09/12 16:36

提示のコードを精査してませんが、 AutoFontSizeは、テキストボックスのサイズを元に、そのサイズに収まるかどうかを判断してフォントサイズを決定しています。 AutoFontSize 社名1, company_FontSize 社名1.Width = company_Width 社名1.Top = 1.5 * cm 社名1.Height = 9.9 * cm だと、AutoFontSize でフォントサイズを決定した後、テキストボックスのサイズを変更していますが、先にサイズを変更してから、AutoFontSize を実行するようにしたらどうなりますか。

退会済みユーザー

2023/09/14 02:21

コメントありがとうござます。社名1.Width = company_Width 社名1.Top = 1.5 * cm 社名1.Height = 9.9 * cm AutoFontSize 社名1, company_FontSize に変えてみましたが、特に文字の大きさに改善は見られませんでした。

hatena19

2023/09/14 02:27

それ以外の部分でも、テキストボックスのサイズを変更したり、RightMargin を変更したりしているコードがあります。とりあえず問題を切り分けるために、テキストボックスを1個のみ配置して、そのテキストボックスに AutoFontSize を実行した場合、同様の現象が発生するか確認してください。

退会済みユーザー

2023/09/14 02:41

Private Sub 詳細_Format(Cancel As Integer, FormatCount As Integer) Const cm As Integer = 567 'twipsをcm表記社名1.Width = 1 * cm 社名1.Height = 10 * cm 社名1.TextAlign = 4 AutoFontSize 社名1, 25 End Sub こちらのコードのみで実行したところ、データが何文字でも理想通りのフォントサイズになりました。

hatena19

2023/09/14 02:54

ということはAutoFontSizeの問題ではなく、それ以外の部分のコードに原因があることになります。となると、現状のコードでステップ実行して、どこで希望のフォントサイズから変更されるのか確認して問題部分を探索するというデバッグ作業をすることになりますね。その作業は質問者さんの仕事だと思います。そのうえで問題部分を特定して、なおかつ解決できない場合は、その部分についての詳細を説明して再質問してください。