通过CADVBA生成坐标表(原创)

Public Sub xy()
Dim ENT As AcadEntity
Dim pickpoint As Variant
Dim PL_ent As AcadLWPolyline

ThisDrawing.Utility.GetEntity ENT, pickpoint, "请选择要生成坐标表的线："

If TypeOf ENT Is AcadLWPolyline Then
Set PL_ent = ENT
Dim pointXY() As Double
Dim point() As Double
point = ThisDrawing.Utility.GetPoint(, "请拾取表格放置点：")

pointXY = PL_ent.Coordinates

Dim i As Integer, n As Integer
n = (UBound(pointXY) - 1) / 2

Dim PL_biao As AcadLWPolyline
Dim PL_xy(0 To 3) As Double

PL_xy(0) = point(0)
PL_xy(1) = point(1)
PL_xy(2) = point(0)
PL_xy(3) = point(1) - 0.5 * (n + 2)

Set PL_biao = ThisDrawing.ModelSpace.AddLightWeightPolyline(PL_xy)
PL_xy(0) = point(0) + 1
PL_xy(2) = point(0) + 1
Set PL_biao = ThisDrawing.ModelSpace.AddLightWeightPolyline(PL_xy)
PL_xy(0) = point(0) + 4
PL_xy(2) = point(0) + 4
Set PL_biao = ThisDrawing.ModelSpace.AddLightWeightPolyline(PL_xy)
PL_xy(0) = point(0) + 7
PL_xy(2) = point(0) + 7
Set PL_biao = ThisDrawing.ModelSpace.AddLightWeightPolyline(PL_xy)

PL_xy(0) = point(0)
PL_xy(1) = point(1)
PL_xy(2) = point(0) + 7
PL_xy(3) = point(1)

Set PL_biao = ThisDrawing.ModelSpace.AddLightWeightPolyline(PL_xy)

For i = 0 To n + 1
PL_xy(1) = point(1) - 0.5 * (i + 1)
PL_xy(3) = point(1) - 0.5 * (i + 1)
Set PL_biao = ThisDrawing.ModelSpace.AddLightWeightPolyline(PL_xy)
Next i

Dim Inserpoint(0 To 2) As Double, inserpoint_X(0 To 2) As Double, inserpoint_Y(0 To 2) As Double
Dim TEXT_id As AcadText, TEXT_X As AcadText, TEXT_Y As AcadText
Dim X As String, Y As String

Inserpoint(0) = point(0) + 0.5
Inserpoint(1) = point(1) - 0.25
Inserpoint(2) = 0

inserpoint_X(0) = point(0) + 2.5
inserpoint_X(1) = point(1) - 0.25
inserpoint_X(2) = 0

inserpoint_Y(0) = point(0) + 5.5
inserpoint_Y(1) = point(1) - 0.25
inserpoint_Y(2) = 0

Set TEXT_id = ThisDrawing.ModelSpace.AddText("序号", Inserpoint, 0.36)
Set TEXT_X = ThisDrawing.ModelSpace.AddText("X 坐标", inserpoint_X, 0.36)
Set TEXT_Y = ThisDrawing.ModelSpace.AddText("Y 坐标", inserpoint_Y, 0.36)

TEXT_id.Alignment = acAlignmentMiddle
TEXT_id.TextAlignmentPoint = Inserpoint
TEXT_id.Alignment = acAlignmentLeft

TEXT_X.Alignment = acAlignmentMiddle
TEXT_X.TextAlignmentPoint = inserpoint_X
TEXT_X.Alignment = acAlignmentLeft

TEXT_Y.Alignment = acAlignmentMiddle
TEXT_Y.TextAlignmentPoint

= inserpoint_Y
TEXT_Y.Alignment = acAlignmentLeft

Inserpoint(0) = point(0) + 0.5
Inserpoint(1) = point(1) - 0.75
Inserpoint(2) = 0

inserpoint_X(0) = point(0) + 2.5
inserpoint_X(1) = point(1) - 0.75
inserpoint_X(2) = 0

inserpoint_Y(0) = point(0) + 5.5
inserpoint_Y(1) = point(1) - 0.75
inserpoint_Y(2) = 0

Dim QZ As String
QZ = InputBox(" 请输入界址点前缀：")


For i = 0 To n
Y = Format(Round(pointXY(2 * i), 3), "###.000")
X = Format(Round(pointXY(2 * i + 1), 3), "###.000")

Set TEXT_id = ThisDrawing.ModelSpace.AddText(QZ & (i + 1), Inserpoint, 0.36)
Set TEXT_X = ThisDrawing.ModelSpace.AddText(X, inserpoint_X, 0.36)
Set TEXT_Y = ThisDrawing.ModelSpace.AddText(Y, inserpoint_Y, 0.36)

TEXT_id.Alignment = acAlignmentMiddle
TEXT_id.TextAlignmentPoint = Inserpoint
TEXT_id.Alignment = acAlignmentLeft

TEXT_X.Alignment = acAlignmentMiddle
TEXT_X.TextAlignmentPoint = inserpoint_X
TEXT_X.Alignment = acAlignmentLeft

TEXT_Y.Alignment = acAlignmentMiddle
TEXT_Y.TextAlignmentPoint = inserpoint_Y
TEXT_Y.Alignment = acAlignmentLeft


Inserpoint(1) = Inserpoint(1) - 0.5
inserpoint_X(1) = inserpoint_X(1) - 0.5
inserpoint_Y(1) = inserpoint_Y(1) - 0.5

Next i

Else
MsgBox "所选的对象不是多段线，请重新选择！"
Exit Sub
End If

End Sub