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 |