批量修改等高线的问题
<p>使用acSelectionSetCrossing命令后，框选内会有多余的线条选中，本人只希望选择和参考线相交的等高线进行高程赋值，望高手帮忙解决！</p><p> </p><p>原代码如下：</p><p> </p><p> </p><p>Public Sub AddEelaviont()</p><p> On Error Resume Next<br/> <br/> Dim LineObj As AcadLine '定义等高线方向线<br/> Dim Ss As AcadSelectionSet<br/> Dim StartPoint As Variant<br/> Dim EndPoint As Variant<br/> <br/> ' 在没有提示参考点的情况下获取第一个点<br/> StartPoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "输入直线起点: ")<br/> ' 利用上边起点作为参考点获取第二个点<br/> EndPoint = ThisDrawing.Utility.GetPoint(StartPoint, vbCrLf & "输入直线终点: ")<br/> Set LineObj = ThisDrawing.ModelSpace.AddLine(StartPoint, EndPoint) '画出参考线<br/> <br/> Dim RemoveObjects As AcadEntity<br/> Set RemoveObjects = LineObj<br/> <br/> <br/> ThisDrawing.SelectionSets("Test").Delete<br/> Set Ss = ThisDrawing.SelectionSets.Add("Test")<br/> Ss.Select acSelectionSetCrossing, StartPoint, EndPoint '如果StartPoint和EndPoint框<br/> '内有多余的线就会出现问题了。<br/> '要修改的只是和参考线相交线的高程。<br/> If Ss.Count = 0 Then '错误判断<br/> MsgBox "未选择到对象！", vbCritical<br/> Ss.Delete<br/> Exit Sub<br/> End If</p><p>Ss.RemoveItems RemoveObjects<br/>Dim I As Integer<br/>Dim Pl As AcadPolyline<br/>Dim IntPoints As Variant<br/>Dim II As Integer<br/>Dim JJ As Integer '定义相交线数组位置<br/>Dim str As String<br/>Dim No() As Integer '选择实体的顺序数组<br/>Dim Pts() As Double '到线端点的距离数组</p><p><br/>Dim sPt As Variant<br/>sPt = StartPoint '线的起点<br/>JJ = 0<br/>For I = 1 To Ss.Count - 1<br/> Ss.Item(I).Elevation = 0<br/> Ss.Item(I).Update<br/> IntPoints = Ss.Item(I).IntersectWith(LineObj, acExtendNone) '这里有问题了<br/> <br/> ReDim Preserve No(JJ)<br/> ReDim Preserve Pts(JJ)<br/> <br/> If UBound(IntPoints) <> -1 Then<br/> Pts(JJ) = GetDist(sPt(0), sPt(1), IntPoints(0), IntPoints(1)) '计算距离<br/> No(JJ) = JJ<br/> JJ = JJ + 1<br/> Else<br/> Ss.RemoveItems I<br/> Ss.Item(I).Update<br/> End If<br/> <br/>Next I</p><p>'按距起点的距离进行排序</p><p>Dim J As Integer<br/>Dim Temp As Double<br/>Dim Itemp As Integer<br/>Dim Exchange As Boolean<br/>Dim Ncount As Integer<br/>Ncount = JJ</p><p>For I = 0 To Ncount - 1 '交换排序->冒泡排序<br/> Exchange = False<br/> For J = Ncount - 2 To I Step -1<br/> If Pts(J + 1) < Pts(J) Then<br/> Temp = Pts(J + 1)<br/> Pts(J + 1) = Pts(J)<br/> Pts(J) = Temp<br/> Itemp = No(J + 1)<br/> No(J + 1) = No(J)<br/> No(J) = Itemp<br/> Exchange = True<br/> End If<br/> Next<br/> If Not Exchange Then<br/> J = I + 1<br/> End If<br/>Next</p><p>Dim StartH As Double<br/>Dim StepH As Double<br/>StartH = ThisDrawing.Utility.GetReal("输入起点高程值:")<br/>StepH = ThisDrawing.Utility.GetReal("输入高程增值:")<br/>For II = 0 To Ncount - 1<br/>Ss.Item(II).Elevation = StartH + II * StepH<br/>Next<br/>'Delete LineObj<br/>MsgBox "总共处理了" & Ncount & "条线"<br/>End Sub</p><p>Public Function GetDist(X1, Y1, X2, Y2)<br/>GetDist = Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)<br/>End Function<br/></p> <p class="syntax">RetVal = object.IntersectWith(IntersectObject, ExtendOption) </p><p class="element">ExtendOption</p><p class="element-desc">AcExtendOption 常数; 为输入项<br/>该选项指定两个对象中是否没有、单个或两个对象延伸来得到交点。</p><table class="Simple"><tbody><tr valign="top"><td><p class="constant">acExtendNone</p></td><td><p class="constant-desc">两个对象均不延伸。</p></td></tr><tr valign="top"><td><p class="constant">acExtendThisEntity</p></td><td><p class="constant-desc">延伸基本对象。</p></td></tr><tr valign="top"><td><p class="constant">acExtendOtherEntity</p></td><td><p class="constant-desc">延伸作为参数传递的对象。</p></td></tr><tr valign="top"><td><p class="constant">acExtendBoth</p></td><td><p class="constant-desc">延伸两个对象。</p></td></tr></tbody></table><p class="element">RetVal</p><p class="element-desc">Variant[变体] (双精度数组)<br/>点数组为图形中对象与其它对象相交的点数组。 </p><p class="element-desc">用这个判断吧！你是想编切剖面工具吧？</p> <p>首先谢谢天涯海角关注，本人的确是想编写一个切剖面工具，实际上我已经使用你介绍的判断，但选择集的时候，得到交点会有错！本人判断是选择集的时候这句代码Ss.Select acSelectionSetCrossing, StartPoint, EndPoint，有问题，会把多余的线选中！</p> 多余的线？选择集里凡是跟你的参考线相交的等高线都可以判断出来的啊！不明白你的意思！还有，想编切剖面工具的，想必是搞水利方面的人了，最有可能是水工的，呵呵！一起努力！ 呵呵，我是搞地质的，纯矿产。我从网上找到切剖面后续程序，只是自己想按照工作需求进行修改完善，没有想到刚开始就遇到问题。在线请教QQ：24004936 呵呵，前来学习
页:
[1]