vba 检查cad中字体高度不得小于多少

当CAD中的文字标注注释等文字过小时候，在预览时候很难发现。打印出来之后才发现，文字过小，看不清楚。晒成蓝图可能更看不清楚。

因此写了个小程序，检查文字高度不得小于多少（比如300）如果小于300则改为300高。
同时还有检查参照块中的文字，文字高的乘以块的放大系数，同样不得小于最小高度。

Sub CheckTextHeight()
    Dim T As AcadText
    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

    For Each T In ThisDrawing.ModelSpace
        H = T.height
        If H < LH Then
            T.height = LH
            N = N + 1
        End If
    Next

    '检查图块中的文字
    '   如果参照图块中的文字高度乘以图块的放大系数小于文字的最小高度，则改为文字的最小高度除以图块的放大系数。
    Dim E As AcadEntity
    Dim B As AcadBlock
    Dim BRef As AcadBlockReference
    For Each E In ThisDrawing.ModelSpace
        If E.ObjectName = "AcDbBlockReference" Then
            MsgBox E.Name
            Set B = ThisDrawing.Blocks(E.Name)
            Set BRef = E
            For Each T In B
                H = T.height
                Sc = BRef.YScaleFactor
                If LH > H * Sc Then
                   T.height = LH / Sc
                   N = N + 1
                End If
            Next
        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

[本日志由田草于 2007-07-07 09:28 PM 编辑]

分享到： QQ空间新浪微博腾讯微博微信更多