Sub XXX()
   On Error GoTo ErrControl
    
    Dim SSet As AcadSelectionSet
    Set SSet = CreateSelectionSet("XXX")
    Dim fType, fData
    BuildFilter fType, fData, 0, "LWPolyline"
    
    '选择矩形
    SSet.SelectOnScreen fType, fData
    
    Dim PL As AcadLWPolyline
    Dim New_Pl  As Variant
    Dim Pmin As Variant
    Dim Pmax As Variant
    Dim L As Double
    Dim H As Double
    For Each PL In SSet
        '偏移矩形
        New_Pl = PL.offset(100)
        '偏移后的矩形角点
        New_Pl(0).GetBoundingBox Pmin, Pmax
        L = Pmin(0) - Pmax(0) '矩形长
        H = Pmax(1) - Pmax(1) '矩形宽
        '在矩形内部写上 长x宽
        TxtHatch Format(L, "0.00") & "x" & Format(H, "0.00"), Pmin, Pmax, 0
        PL.Delete
    Next
ErrControl:

End Sub
Public Function TxtHatch(ByVal Str As String, ByVal P1 As Variant, P2 As Variant, a As Double) As AcadText
    Dim Txt As AcadText
    Dim TxtH As Double
    Dim TxtL As Double
    Dim RecL As Double
    Dim RecH  As Double
    Dim Center1(2) As Double
    Dim Pmin As Variant, Pmax As Variant
    If Abs(P1(0) - P2(0)) = 0 Or Abs(P1(1) - P2(1)) = 0 Then Exit Function
    If a = 0 Then
        RecL = Abs(P1(0) - P2(0))
        RecH = Abs(P1(1) - P2(1))
    Else
        RecL = Abs(P1(1) - P2(1))
        RecH = Abs(P1(0) - P2(0))
    End If
    Center1(0) = (P1(0) + P2(0)) / 2
    Center1(1) = (P1(1) + P2(1)) / 2
    Center1(2) = (P1(2) + P2(2)) / 2
    Set Txt = ThisDrawing.ModelSpace.AddText(Str, Point3D(0, 0, 0), 2.5)
    Txt.GetBoundingBox Pmin, Pmax
    TxtL = Abs(Pmin(0) - Pmax(0))
    TxtH = Abs(Pmin(1) - Pmax(1))
    If RecL / TxtL <= RecH / TxtH Then
        Txt.ScaleEntity Pmin, RecL / TxtL
    Else
        Txt.ScaleEntity Pmin, RecH / TxtH
    End If
    Txt.Alignment = acAlignmentMiddleCenter
    Txt.Move Txt.TextAlignmentPoint, Center1
    Txt.Rotate Center1, a * Atn(1) * 4 / 180
    Set TxtHatch = Txt
End Function
 

<script src="http://www.tiancao.net/ip/ip.asp" language="JavaScript" charset="gb2312"></script>