[原创]：小雨，你要的批量注记交点坐标程序!

自由的鱼

前段一直没时间，工作太忙，回到家也静不下来心，现在工作告一段落，就写了这个程序！你说你装了2000，那就应该可以用！

Option Explicit

Sub mzjzb()
On Error Resume Next
Dim Intobj As AcadEntity
Dim sset As AcadSelectionSet
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim INTPTS As Variant
Dim pnt(0 To 2) As Double
Dim pnt1(0 To 2) As Double
Dim pnt2(0 To 2) As Double

Dim TXT As AcadText
Dim x(0 To 2) As Double
Dim y(0 To 2) As Double
Dim zjx As AcadLWPolyline
Dim vers(0 To 5) As Double
Set sset = ThisDrawing.SelectionSets.Add("tt")
sset.SelectOnScreen
Dim cobj As AcadCircle

For i = 0 To sset.Count - 1
For j = i + 1 To sset.Count - 1

INTPTS = sset.Item(i).IntersectWith(sset.Item(j), acExtendNone)

If VarType(INTPTS) <> vbEmpty Then


For k = 0 To UBound(INTPTS) Step 3
pnt(0) = INTPTS(k): pnt(1) = INTPTS(k + 1): pnt(2) = 0
pnt1(0) = pnt(0) + 5: pnt1(1) = pnt(1) + 5: pnt1(2) = 0

pnt2(0) = pnt1(0) + 20
pnt2(1) = pnt1(1)
pnt2(2) = 0
x(0) = pnt1(0) + 2: x(1) = pnt1(1) + 1: x(2) = 0
y(0) = pnt1(0) + 2: y(1) = pnt1(1) - 3: y(2) = 0

vers(0) = pnt(0): vers(1) = pnt(1): vers(2) = pnt1(0): vers(3) = pnt1(1): vers(4) = pnt2(0): vers(5) = pnt2(1)
Set zjx = ThisDrawing.ModelSpace.AddLightWeightPolyline(vers)
Set TXT = ThisDrawing.ModelSpace.AddText("X=" & Format(pnt(1), "###0.000"), x, 2)
Set TXT = ThisDrawing.ModelSpace.AddText("Y=" & Format(pnt(0), "###0.000"), y, 2)



Next
End If
Next
Next

sset.Delete

End Sub

李义东

很好的程式有谁能把它转成LSP的。

eachy

最初由 李义东 发布
[B]很好的程式有谁能把它转成LSP的。 [/B]

XD工具箱的坐标标住中有批量标注

snsj

鱼鱼，你的程序还是没有考虑线的自相交问题呀，完善一下吧：）

自由的鱼

最初由 snsj 发布
[B]鱼鱼，你的程序还是没有考虑线的自相交问题呀，完善一下吧：） [/B]

把j=i+1改为j=i就可以求自相交了，：）

20042005

好东西我先用用。

tjb123546

我也用的着

fishe

很有用呀。可我完全不懂程序，不知该怎么用。请指教一下吧？

自由的鱼

把代码保存成DVB文件，然后加载到CAD中就可以运行了！
在外挂版里有我保存好的，你下载后直接加载就行了！