[分享]：※※※※交点插物体程序※※※※

snsj

[swf w=512 h=482]http://www.xdcad.net/bbstech/snsj/snsj-ints.swf[/swf]

wowoaicad

这个东东不错啊，如果能加上支持在同一水平线上的交点插入就更好了

zxdcad

楼主，你这个东东好是好，但功能还比较弱呀！！！！希望你再接再历，完善它，好吗！！！


圆与直线相交不能处理；

圆弧与直线有两交点时不能处理；

椭圆及椭圆弧与直线相交不能处理；

多段线与直线相交不能处理；

这是我试了一下发现的问题。希楼主能完善就好了！！！！

andyhua5240

急待完善！
谢谢楼主！

snsj

谢谢大家支持，修改如下，请大家测试

jerry_bj

这个程序有自动判断交点功能，期待这个与坐标标注结合起来 做到一次标注多点坐标

自由的鱼

最初由 jerry_bj 发布
[B]这个程序有自动判断交点功能，期待这个与坐标标注结合起来 做到一次标注多点坐标 [/B]

注记坐标等有时间再加吧

Option Explicit

Sub ints()
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
For i = 0 To ThisDrawing.SelectionSets.Count - 1
    ThisDrawing.SelectionSets.Item(i).Clear
    ThisDrawing.SelectionSets.Item(i).Delete
Next


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) = INTPTS(k + 2)
Set cobj = ThisDrawing.ModelSpace.AddCircle(pnt, 2)
Debug.Print INTPTS(k) & " " & INTPTS(k + 1) & " " & INTPTS(k + 2)
Next
End If
Next
Next



End Sub

snsj

鱼鱼能把你写的程序功能介绍一下么:)

自由的鱼

最初由 snsj 发布
[B]鱼鱼能把你写的程序功能介绍一下么:) [/B]

呵呵，和您的功能一样，也是在交点上插一个小圆，注记坐标的功能我还没有加上去，等有时间再写~~：）

雪山飞狐(lzh)

好像不能求曲线自身交点
For j = i + 1 To sset.Count - 1
改为
For j = i  To sset.Count - 1
就可以了
而且你什么要删除所有选择集呢？

自由的鱼

最初由 lzh741206 发布
[B]好像不能求曲线自身交点
For j = i + 1 To sset.Count - 1
改为
For j = i  To sset.Count - 1
就可以了
而且你什么要删除所有选择集呢？ [/B]

呵呵，简单一点~~因为我平时没有用到自身交点坐标，所以将它过滤掉！

雪山飞狐(lzh)

简单一点是直接引用ActiveSelectionSet，不用删除所有选择集

自由的鱼

最初由 lzh741206 发布
[B]简单一点是直接引用ActiveSelectionSet，不用删除所有选择集 [/B]

没具体去写，就全删除了，：）

七月流萤

谢谢，很好用的

lzy9788

能实现这样的效果吗，我想在屏幕上通过点取两点来得到这两点连线与连线间所有线(LINE,PLINE,弧线,圆等)的交点列表(我主要是想得到交点列点)。