[VBA程序]：请问如何在等高线图上截出地面线？

ymd

仅过2d多义线取高程是比较快的，但地形图上含高程信箱的实体很多，不同图层也可能有不同信箱，应全部处理，
另外，通过当前图取高程始终速度满！

god

最初由 ymd 发布
[B]仅过2d多义线取高程是比较快的，但地形图上含高程信箱的实体很多，不同图层也可能有不同信箱，应全部处理，
另外，通过当前图取高程始终速度满！ [/B]

高手，你说的信箱是什么？

请问你的这个帖子。
http://www.xdcad.net/forum/showt ... d=669869#post669869
演示的图约2.9km路线长，在ACAD2002上不要十秒钟，因直接对实体进行处理（不用CAD剪裁），命令，速度比较快！

“直接对实体进行处理”是怎么做的？

雪山飞狐(lzh)

以下是一个测试代码，实际操作要考虑更多问题
先再屏幕上画出截面（直线）再运行，保证直线与样式曲线有投影交点
Sub t9()
On Error GoTo ErrHandle
    Dim ss As AcadSelectionSet
    Dim ssLine As AcadSelectionSet
    Dim ft(0) As Integer, fd(0)
    Dim p1(2) As Double, p2(2) As Double
    Dim pPnts()
    Dim pLine As AcadLine, dot
    Dim i, j
    Dim pInsertPnt
    Dim pInsertPnts()
    Dim pNum As Integer
    Dim pnt(2) As Double
   
    Dim pStart, PEnd
    Dim pCount As Integer
    Dim pDistances() As Double
   

    Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
    ft(0) = 0: fd(0) = "Spline"
    ss.Select acSelectionSetAll, , , ft, fd
    ReDim pPnts(ss.Count - 1)
    For i = 0 To ss.Count - 1
    pPnts(i) = ss(i).ControlPoints
    p1(2) = pPnts(i)(2)
    ss(i).Move p1, p2
    Next i
   
   
    Set ssLine = ThisDrawing.SelectionSets.Add("*TlsTestLine*")
    ft(0) = 0: fd(0) = "Line"

    ssLine.Select acSelectionSetAll, , , ft, fd
    For Each pLine In ssLine
    pNum = 0
    For i = 0 To ss.Count - 1
        pInsertPnt = pLine.IntersectWith(ss(i), acExtendNone)
        n = (UBound(pInsertPnt) + 1) / 3
        For j = 0 To n - 1
            pnt(0) = pInsertPnt(j * 3)
            pnt(1) = pInsertPnt(j * 3 + 1)
            pnt(2) = pPnts(i)(2)
            ReDim Preserve pInsertPnts(pNum)
            pInsertPnts(pNum) = pnt
            pNum = pNum + 1
        Next j
    Next i
   
    pStart = pLine.StartPoint
    PEnd = pLine.EndPoint
    pCount = UBound(pInsertPnts)
   
    If Abs(Tan(pLine.Angle)) < 1 Then pNum = 0 Else pNum = 1
   
    ReDim pDistances(pCount) As Double
    For i = 0 To pCount
        pDistances(i) = Abs(pInsertPnts(i)(pNum) - pStart(pNum))
    Next i
    SortPoint pDistances, pInsertPnts, pCount
    Dim pDPnts() As Double
    pNum = UBound(pInsertPnts) * 3 + 2
    ReDim pDPnts(pNum) As Double
    For i = 0 To UBound(pInsertPnts)
        pDPnts(i * 3) = pInsertPnts(i)(0)
        pDPnts(i * 3 + 1) = pInsertPnts(i)(1)
        pDPnts(i * 3 + 2) = pInsertPnts(i)(2)
    Next i
    ThisDrawing.ModelSpace.Add3DPoly(pDPnts).Rotate3D pLine.StartPoint, pLine.EndPoint, Atn(1) * 2
    Next pLine


ErrHandle:
    For i = 0 To ss.Count - 1
    p1(2) = pPnts(i)(2)
    ss(i).Move p2, p1
    Next i
    ThisDrawing.SelectionSets("*TlsTest*").Delete
    ThisDrawing.SelectionSets("*TlsTestLine*").Delete
End Sub


Private Sub SortPoint(ByRef Values As Variant, ByRef Points As Variant, ByVal Count As Integer)
'按值将点数组排序
    Dim pTemp As Double, pnt As Variant
   
    For i = Count To 1 Step -1
   
        For j = 0 To i - 1
        
            If Values(j) > Values(j + 1) Then
                pTemp = Values(j + 1)
                Values(j + 1) = Values(j)
                Values(j) = pTemp
                pnt = Points(j + 1)
                Points(j + 1) = Points(j)
                Points(j) = pnt
            End If
            
        Next j
        
    Next i
   
End Sub

god

真是高手，这么快就做好了。

我试了一下，只有在平面相交的才能找到交点，投影相交不行。
这个帖子可以指定投影面相交，vba里怎么用投影相交？http://www.xdcad.net/forum/showthread.php?s=&threadid=171191


请问用多段线过滤该改成什么？lwpolyline也不行
fd(0) = "Spline"，？？
这个值在哪能找到呢？

雪山飞狐(lzh)

投影相交也是可以的，但是你的等高线不太标准，有时第一点的高程和其他的点的高程不等（我的代码是取第一个点的高程，将整条曲线Move到Z＝0），所以没有交点

可以在命令行键入(entget(car(entsel)))查看DXF组码设置过滤器

god

我自己画了几条spline，指定不同的z值，可以了。
不过如果过滤多段线，代码还不能用。

另外怎么做到投影相交呢？

雪山飞狐(lzh)

真正意义上的投影相交VBA是做不到的（对样式曲线而言），Arx的曲线操作比VBA的强太多了，好像Lisp也可以
多段线的过滤器设置为fd(0) ="POLYLINE"
如果等高线是多段线，投影交点可求

god

我的等高线是多段线，怎么求投影相交?

如果是多段线，就不能用.ControlPoints求z坐标。

雪山飞狐(lzh)

Object.Coordinates
将各点的高程置0，就可以求投影到XY的交点

god

研究了一下，受益匪浅，只是还有点似懂非懂。没有注释，看起来要困难一些。
我觉得将直线的z坐标置为多段线的z坐标，再求交点，代码会更有通用性且更简单，并且不用考虑将曲线的高程置0又还原了，因为处理过程中出错的话，就还原不了了。

你能再改改吗？

雪山飞狐(lzh)

按你的水平，这个程序应该可以编出来的吧，而且就算我改过来代码也是不完整的，为什么不试试自己动手做呢？

god

ok，我改了再传上来，请你批批。

我只是觉得你编的代码，改起来会快一些，我还没完全看懂呢。

小美菜

Public Function Fun直线是否穿过三角形(SO As Acad3DPolyline, L1 As Variant, L2 As Variant, ByRef tmpPnt() As pPoint) As Integer
   Dim Pnt1(2) As Double, Pnt2(2) As Double, Pnt3(2) As Double, i As Integer, tCd As Variant
   Dim P1(2) As Double, P2(2) As Double, P3(2) As Double
   tCd = SO.Coordinates: ReDim tmpPnt(i) '求直线L1 L2是否穿过三角网
   P1(0) = tCd(0): P1(1) = tCd(1): P1(2) = tCd(2)
   P2(0) = tCd(3): P2(1) = tCd(4): P2(2) = tCd(5)
   P3(0) = tCd(6): P3(1) = tCd(7): P3(2) = tCd(8)
   Set tCd = Nothing
   tCd = Fun检查两直线是否相交(L1, L2, P1, P2)
   If tCd(0) = 0 And tCd(1) = 0 And tCd(2) = 0 Then GoTo 1
   tmpPnt(i).x = tCd(0): tmpPnt(i).Y = tCd(1): tmpPnt(i).Z = tCd(2): tmpPnt(i).pN = 12: i = i + 1
1:
   Set tCd = Nothing
   tCd = Fun检查两直线是否相交(L1, L2, P1, P3)
   If tCd(0) = 0 And tCd(1) = 0 And tCd(2) = 0 Then GoTo 2
   ReDim Preserve tmpPnt(i)
   tmpPnt(i).x = tCd(0): tmpPnt(i).Y = tCd(1): tmpPnt(i).Z = tCd(2): tmpPnt(i).pN = 12: i = i + 1
2:
   Set tCd = Nothing
   tCd = Fun检查两直线是否相交(L1, L2, P3, P2)
   If tCd(0) = 0 And tCd(1) = 0 And tCd(2) = 0 Then GoTo 3
   ReDim Preserve tmpPnt(i)
   tmpPnt(i).x = tCd(0): tmpPnt(i).Y = tCd(1): tmpPnt(i).Z = tCd(2): tmpPnt(i).pN = 12: i = i + 1
3:
  Fun直线是否穿过三角形 = i
End Function
Public Function Fun直线是否穿过立体线(SO As AcadLine, L1 As Variant, L2 As Variant, ByRef tmpPnt() As pPoint) As Integer
   Dim i As Integer, tCd As Variant, PStart As Variant, PEnd As Variant
   PStart = SO.StartPoint: PEnd = SO.EndPoint: ReDim tmpPnt(i) '.SO.Coordinates: ReDim tmpPnt(i)   '求直线L1 L2是否穿过三角网
   If PStart(2) = 0 And PEnd(2) = 0 Then Exit Function
   tCd = Fun检查两直线是否相交(L1, L2, PStart, PEnd)
   If tCd(0) = 0 And tCd(1) = 0 And tCd(2) = 0 Then Exit Function
   tmpPnt(i).x = tCd(0): tmpPnt(i).Y = tCd(1): tmpPnt(i).Z = tCd(2): tmpPnt(i).pN = "CRS": i = i + 1
   Fun直线是否穿过立体线 = i
End Function
Public Function Fun检查两直线是否相交(L1 As Variant, L2 As Variant, P1 As Variant, P2 As Variant) As Variant
   Dim Pnt1(2) As Double, TrueIn As Boolean: Fun检查两直线是否相交 = Pnt1: TrueIn = False
   Dim a1 As Double, a2 As Double, b1 As Double, b2 As Double
   Call GetLineV(L1, L2, a1, b1) '求两条直线相交的交点
   Call GetLineV(P1, P2, a2, b2)
   If Abs(a1) = Abs(a2) Then
      If b1 = 0 And b2 = 0 Then
        Exit Function
      ElseIf Not b1 = 0 And Not b2 = 0 Then
        Exit Function
      End If
   End If
   If a1 = 0 And b1 = 0 Then
     Pnt1(0) = L1(0): Pnt1(1) = a2 * Pnt1(0) + b2
   ElseIf a2 = 0 And b2 = 0 Then
     Pnt1(0) = P1(0):: Pnt1(1) = a1 * Pnt1(0) + b1
   Else
     Pnt1(0) = (b1 - b2) / (a2 - a1): Pnt1(1) = a1 * Pnt1(0) + b1
   End If
   If Fun确定点在直线上(Pnt1, L1, L2) = True And Fun确定点在直线上(Pnt1, P1, P2) = True Then Fun检查两直线是否相交 = Pnt1
End Function
Public Function GetLineV(L1 As Variant, L2 As Variant, ByRef a1 As Double, ByRef b1 As Double)
   Dim Dx As Double, dY As Double  '求两点之间的直线斜率
   Dx = L2(0) - L1(0): dY = L2(1) - L1(1)
   Dx = GetDblPrice(Dx, 5)
   If Dx = 0 Then a1 = 0: b1 = 0 Else a1 = dY / Dx: b1 = L1(1) - a1 * L1(0)
End Function
Public Function GetDist(L1 As Variant, L2 As Variant) As Double
   Dim Dx As Double, dY As Double '求两点之间的距离
   Dx = L1(0) - L2(0): dY = L1(1) - L2(1)
   GetDist = Sqr(Dx * Dx + dY * dY)
End Function
Public Function Fun确定点在直线上(ByRef Pnt1 As Variant, P1 As Variant, P2 As Variant) As Boolean    '(L1 As Variant, L2 As Variant, ByRef a1 As Double, ByRef b1 As Double)
   Dim a As Double, b As Double, x As Double, Y As Double, s As Double, dH As Double: Fun确定点在直线上 = False
   Dim v1 As Double, v2 As Double, Su As Double
   Call GetLineV(P1, P2, a, b) 'If Pnt1(0) >= P1(0) Then If Pnt1(0) <= P2(0) Then X = True
   Su = GetDist(P1, P2): v1 = GetDist(Pnt1, P1): v2 = GetDist(Pnt1, P2)
   s = a * Pnt1(0) + b 'If Pnt1(0) >= P2(0) Then If Pnt1(0) <= P1(0) Then X = True
   s = Abs(s - Pnt1(1)): Su = Abs(Su - v1 - v2) 'If Pnt1(1) >= P1(1) Then If Pnt1(1) <= P2(1) Then Y = True   'If Pnt1(1) >= P2(1) Then If Pnt1(1) <= P1(1) Then Y = True
   If s < 0.002 And Su < 0.002 Then '确定计算出的点是否的确是与直线P1 P2相交点且在直线上
     Fun确定点在直线上 = True
     dH = P1(2) - P2(2): s = dH / GetDist(P1, P2) 'dX = Pnt1(0) - P2(0): dY = Pnt1(1) - P2(1)
     Pnt1(2) = P2(2) + s * GetDist(Pnt1, P2)
   End If
End Function

god

炒菜大师的小菜还不错。值得品尝品尝。