[VBA函数]：各位高手可否帮忙？急！

weilufeng

一条直线与几个直线相交，用什么方法自动识别与几条直线相交并且得到其相交的点的3D坐标；其实这个问题的原始问题是在二维地形图中求一solid与几条等高线pline相交并求其交点坐标，并绘出其纵断面。（本人才接触二次开发，用的是VB或者VBA，望各位高手多多指教！）

efan2000

看看下面的例子。

2. 
   
3.   [FONT=courier new]
   
4. 
   
5. Sub Test()
   
6.     On Error Resume Next
   
7.     ' 选择直线
   
8.     Dim EntObj(0 To 0) As AcadEntity
   
9.     Dim pPt As Variant
   
10.     ThisDrawing.Utility.GetEntity EntObj(0), pPt, "选择直线: "
    
11.     If EntObj(0) Is Nothing Then Exit Sub
    
12.     ' 求直线的外框
    
13.     Dim Pt1 As Variant
    
14.     Dim Pt2 As Variant
    
15.     EntObj(0).GetBoundingBox Pt1, Pt2
    
16.    
    
17.     ' 创建选择集
    
18.     Dim ssetObj As AcadSelectionSet
    
19.     Set ssetObj = ThisDrawing.SelectionSets("SSET")
    
20.     If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")
    
21.     ssetObj.Clear
    
22.     ' 选择与该直线相交或者包含在外框中的所有实体
    
23.      ssetObj.Select acSelectionSetCrossing, Pt1, Pt2
    
24.      If ssetObj.Count = 0 Then Exit Sub
    
25.      
    
26.      ' 由于其中包含了自身实体，故应从选择集中移走
    
27.      ' 由于移去函数的参数是对象集合，所以在上面定义的是单个对象的对象集合
    
28.      ssetObj.RemoveItems EntObj
    
29.      
    
30.      '枚举交点，判断是否相交
    
31.      Dim Pts As Variant
    
32.      Dim i As Integer
    
33.      For i = 0 To ssetObj.Count - 1
    
34.         Pts = ssetObj(i).IntersectWith(EntObj(0), acExtendNone)
    
35.         If Not IsEmpty(Pts) Then
    
36.             Debug.Print "实体" & ssetObj(i).Handle & "与直线" & EntObj(0).Handle & "相交"
    
37.         End If
    
38.     Next
    
39. End Sub
    
40. 
    
41.   [/FONT]
    

<br />   [FONT=courier new]<br /> <br /> Sub Test()<br />     On Error Resume Next<br />     ' 选择直线<br />     Dim EntObj(0 To 0) As AcadEntity<br />     Dim pPt As Variant<br />     ThisDrawing.Utility.GetEntity EntObj(0), pPt, "选择直线: "<br />     If EntObj(0) Is Nothing Then Exit Sub<br />     ' 求直线的外框<br />     Dim Pt1 As Variant<br />     Dim Pt2 As Variant<br />     EntObj(0).GetBoundingBox Pt1, Pt2<br />     <br />     ' 创建选择集<br />     Dim ssetObj As AcadSelectionSet<br />     Set ssetObj = ThisDrawing.SelectionSets("SSET")<br />     If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")<br />     ssetObj.Clear<br />     ' 选择与该直线相交或者包含在外框中的所有实体<br />      ssetObj.Select acSelectionSetCrossing, Pt1, Pt2<br />      If ssetObj.Count = 0 Then Exit Sub<br />      <br />      ' 由于其中包含了自身实体，故应从选择集中移走<br />      ' 由于移去函数的参数是对象集合，所以在上面定义的是单个对象的对象集合<br />      ssetObj.RemoveItems EntObj<br />      <br />      '枚举交点，判断是否相交<br />      Dim Pts As Variant<br />      Dim i As Integer<br />      For i = 0 To ssetObj.Count - 1<br />         Pts = ssetObj(i).IntersectWith(EntObj(0), acExtendNone)<br />         If Not IsEmpty(Pts) Then<br />             Debug.Print "实体" & ssetObj(i).Handle & "与直线" & EntObj(0).Handle & "相交"<br />         End If<br />     Next<br /> End Sub<br /> <br />   [/FONT]<br />