Sub CheckTextHeight()
    Dim T As AcadText
    Dim MT As AcadMText
    Dim H As Long
    Dim LH As Long
    Dim Sc As Double
    Dim N As Long
   'On Error Resume Next
    
    LH = 300
    LH = ThisDrawing.Utility.GetDistance(, "输入最小文字高度(" & LH & "):")
    '错误检查
    If Err.Number = -2147352567 Then                                    '用户按下Esc键,则退出.(错误代码可以通过MsgBox提示获得)
        Err.Clear
        Exit Sub
    ElseIf Err Then                                                     '如果用户按下 enter 按钮或者输入有误,使用默认值
        LH = 300
        Err.Clear
    End If

    Prompt str(LH)
    '检查图块中的文字
    '   如果参照图块中的文字高度乘以图块的放大系数小于文字的最小高度，则改为文字的最小高度除以图块的放大系数。
    Dim E As AcadEntity
    Dim E1 As AcadEntity
    Dim B As AcadBlock
    Dim Bref As AcadBlockReference
    For Each E In ThisDrawing.ModelSpace
        'Prompt E.ObjectName
        If E.ObjectName = "AcDbBlockReference" Then
            Set B = ThisDrawing.Blocks(E.Name)
            Set Bref = E
            For Each E1 In B
            'Prompt E1.ObjectName
                If E1.ObjectName = "AcDbText" Then
                    Set T = E1
                    'Prompt T.textString
                    H = T.height
                    Sc = Bref.YScaleFactor
                    If LH > H * Sc Then
                        T.height = LH / Sc
                        N = N + 1
                    End If
                End If
            Next
        ElseIf E.ObjectName = "AcDbText" Then
                    Set T = E
                    Prompt T.textString
                    H = T.height
                    If LH > H Then T.height = LH: N = N + 1
        ElseIf E.ObjectName = "AcDbMText" Then
                    Set MT = E
                    'Prompt T.textString
                    H = MT.height
                    If LH > H Then MT.height = LH: N = N + 1
        End If
    Next
       
    ThisDrawing.SendCommand "re" & vbLf
    '
    If N = 0 Then
        ThisDrawing.Utility.Prompt ("图中没有出现字体高度小于" & LH & "mm高的文字." & vbLf)
    Else
        ThisDrawing.Utility.Prompt ("图中共有" & N & "处字体过小，已经将其全部调整为" & LH & "mm高" & vbLf)
    End If
    
End Sub