批量修改等高线的问题

jiandan321

使用acSelectionSetCrossing命令后，框选内会有多余的线条选中，本人只希望选择和参考线相交的等高线进行高程赋值，望高手帮忙解决！

 

原代码如下：

 

 

Public Sub AddEelaviont()

   On Error Resume Next
  
   Dim LineObj As AcadLine '定义等高线方向线
   Dim Ss As AcadSelectionSet
   Dim StartPoint As Variant
   Dim EndPoint As Variant
  
    ' 在没有提示参考点的情况下获取第一个点
   StartPoint = ThisDrawing.Utility.GetPoint(, vbCrLf & "输入直线起点: ")
    ' 利用上边起点作为参考点获取第二个点
   EndPoint = ThisDrawing.Utility.GetPoint(StartPoint, vbCrLf & "输入直线终点: ")
   Set LineObj = ThisDrawing.ModelSpace.AddLine(StartPoint, EndPoint) '画出参考线
  
   Dim RemoveObjects As AcadEntity
   Set RemoveObjects = LineObj
  
    
   ThisDrawing.SelectionSets("Test").Delete
   Set Ss = ThisDrawing.SelectionSets.Add("Test")
   Ss.Select acSelectionSetCrossing, StartPoint, EndPoint '如果StartPoint和EndPoint框
                                                          '内有多余的线就会出现问题了。
                                                          '要修改的只是和参考线相交线的高程。
   If Ss.Count = 0 Then '错误判断
        MsgBox "未选择到对象！", vbCritical
        Ss.Delete
        Exit Sub
    End If

Ss.RemoveItems RemoveObjects
Dim I As Integer
Dim Pl As AcadPolyline
Dim IntPoints As Variant
Dim II As Integer
Dim JJ As Integer '定义相交线数组位置
Dim str As String
Dim No() As Integer '选择实体的顺序数组
Dim Pts() As Double '到线端点的距离数组

Dim sPt As Variant
sPt = StartPoint '线的起点
JJ = 0
For I = 1 To Ss.Count - 1
    Ss.Item(I).Elevation = 0
    Ss.Item(I).Update
    IntPoints = Ss.Item(I).IntersectWith(LineObj, acExtendNone) '这里有问题了
   
    ReDim Preserve No(JJ)
    ReDim Preserve Pts(JJ)
   
    If UBound(IntPoints) <> -1 Then
      Pts(JJ) = GetDist(sPt(0), sPt(1), IntPoints(0), IntPoints(1)) '计算距离
      No(JJ) = JJ
      JJ = JJ + 1
    Else
      Ss.RemoveItems I
      Ss.Item(I).Update
    End If
   
Next I

'按距起点的距离进行排序

Dim J As Integer
Dim Temp As Double
Dim Itemp As Integer
Dim Exchange As Boolean
Dim Ncount As Integer
Ncount = JJ

For I = 0 To Ncount - 1 '交换排序->冒泡排序
   Exchange = False
   For J = Ncount - 2 To I Step -1
      If Pts(J + 1) < Pts(J) Then
        Temp = Pts(J + 1)
        Pts(J + 1) = Pts(J)
        Pts(J) = Temp
        Itemp = No(J + 1)
        No(J + 1) = No(J)
        No(J) = Itemp
        Exchange = True
      End If
    Next
  If Not Exchange Then
     J = I + 1
  End If
Next

Dim StartH As Double
Dim StepH As Double
StartH = ThisDrawing.Utility.GetReal("输入起点高程值:")
StepH = ThisDrawing.Utility.GetReal("输入高程增值:")
For II = 0 To Ncount - 1
Ss.Item(II).Elevation = StartH + II * StepH
Next
'Delete LineObj
MsgBox "总共处理了" & Ncount & "条线"
End Sub

Public Function GetDist(X1, Y1, X2, Y2)
GetDist = Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)
End Function

laoliu09

RetVal = object.IntersectWith(IntersectObject, ExtendOption)

ExtendOption

AcExtendOption 常数; 为输入项
该选项指定两个对象中是否没有、单个或两个对象延伸来得到交点。

acExtendNone	两个对象均不延伸。
acExtendThisEntity	延伸基本对象。
acExtendOtherEntity	延伸作为参数传递的对象。
acExtendBoth	延伸两个对象。

RetVal

Variant[变体] (双精度数组)
点数组为图形中对象与其它对象相交的点数组。

用这个判断吧！你是想编切剖面工具吧？

jiandan321

首先谢谢天涯海角关注，本人的确是想编写一个切剖面工具，实际上我已经使用你介绍的判断，但选择集的时候，得到交点会有错！本人判断是选择集的时候这句代码Ss.Select acSelectionSetCrossing, StartPoint, EndPoint，有问题，会把多余的线选中！

laoliu09

多余的线？选择集里凡是跟你的参考线相交的等高线都可以判断出来的啊！不明白你的意思！还有，想编切剖面工具的，想必是搞水利方面的人了，最有可能是水工的，呵呵！一起努力！

jiandan321

呵呵，我是搞地质的，纯矿产。我从网上找到切剖面后续程序，只是自己想按照工作需求进行修改完善，没有想到刚开始就遇到问题。在线请教QQ：24004936

gzbccy

呵呵，前来学习