三角网内插高程点

pmq

Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.Geometry

Module TriangleElevation

    '三角形内插入高程点
    Sub Main()
        Dim docLock As DocumentLock = Core.Application.DocumentManager.MdiActiveDocument.LockDocument() '“非模态窗口，要锁定文档”
        NativeMethods.SetFocus(Core.Application.DocumentManager.MdiActiveDocument.Window.Handle) 'CAD获得焦点

        ' 获取当前文档和数据库
        Dim doc As Document = Core.Application.DocumentManager.MdiActiveDocument
        Dim db As Database = doc.Database
        Dim ed As Editor = doc.Editor

        ' 提示用户选择三角形（假设三角形是由 3D 面或多段线表示）
        Dim peo As New PromptSelectionOptions()
        peo.MessageForAdding = "请选择三角形（由 3D 面或多段线表示）: "
        Dim psr As PromptSelectionResult = ed.GetSelection(peo)

        ' 检查选择结果是否有效
        If psr.Status <> PromptStatus.OK Then
            ed.WriteMessage("未选择任何三角形对象。")
            Return
        End If

        Do
            ' 遍历选择集中的每个三角形对象
            Using tr As Transaction = db.TransactionManager.StartTransaction()
                ' 提示用户在三角形内拾取一点
                Dim ppr As PromptPointResult = ed.GetPoint("请在三角形内拾取一点: ")

                ' 检查拾取点结果是否有效
                If ppr.Status <> PromptStatus.OK Then
                    ed.WriteMessage("未拾取任何点。")
                    Exit Do
                Else
                    For Each id As ObjectId In psr.Value.GetObjectIds()
                        Dim ent As Entity = tr.GetObject(id, OpenMode.ForRead)
                        ' 检查对象是否为 Polyline 或 Polyline3d
                        If TypeOf ent Is Polyline OrElse TypeOf ent Is Polyline3d Then
                            ' 获取三角形顶点
                            Dim vertices As Point3dCollection = GetTriangleVertices(ent, tr)
                            ' 检查拾取的点是否在三角形内
                            Dim pickedPoint As Point3d = ppr.Value
                            If IsPointInTriangle(vertices, pickedPoint) Then

                                ' 计算拾取点的高程值
                                Dim elevation As Double = CalculateElevation(vertices, pickedPoint)

                                ' 在图上生成点和文本
                                CreatePointAndText(db, tr, pickedPoint, elevation)

                                ' 刷新图形视图以显示新创建的点和文本
                                ed.UpdateScreen()

                                Exit For
                            Else
                                ed.WriteMessage("拾取的点不在三角形内。")
                            End If
                        End If
                    Next

                End If

                tr.Commit()
            End Using
        Loop

        docLock.Dispose()'解锁文档
    End Sub

    ' 获取三角形的顶点
    Function GetTriangleVertices(ent As Entity, tr As Transaction) As Point3dCollection
        Dim vertices As New Point3dCollection()

        If TypeOf ent Is Polyline Then
            Dim pline As Polyline = CType(ent, Polyline)
            For i As Integer = 0 To pline.NumberOfVertices - 1
                vertices.Add(pline.GetPoint3dAt(i))
            Next
        ElseIf TypeOf ent Is Polyline3d Then
            Dim pline3d As Polyline3d = CType(ent, Polyline3d)
            For Each vId As ObjectId In pline3d
                Dim v As PolylineVertex3d = CType(tr.GetObject(vId, OpenMode.ForRead), PolylineVertex3d)
                vertices.Add(v.Position)
            Next
        End If

        Return vertices
    End Function

    ' 计算拾取点的高程值
    Function CalculateElevation(vertices As Point3dCollection, pickedPoint As Point3d) As Double
        ' 确保三角形是平面的
        If vertices.Count <> 3 Then Return 0.0

        ' 使用重心坐标法计算高程值
        Dim x1 As Double = vertices(0).X
        Dim y1 As Double = vertices(0).Y
        Dim z1 As Double = vertices(0).Z

        Dim x2 As Double = vertices(1).X
        Dim y2 As Double = vertices(1).Y
        Dim z2 As Double = vertices(1).Z

        Dim x3 As Double = vertices(2).X
        Dim y3 As Double = vertices(2).Y
        Dim z3 As Double = vertices(2).Z

        Dim x As Double = pickedPoint.X
        Dim y As Double = pickedPoint.Y

        ' 计算重心坐标
        Dim detT As Double = (y2 - y3) * (x1 - x3) + (x3 - x2) * (y1 - y3)
        Dim lambda1 As Double = ((y2 - y3) * (x - x3) + (x3 - x2) * (y - y3)) / detT
        Dim lambda2 As Double = ((y3 - y1) * (x - x3) + (x1 - x3) * (y - y3)) / detT
        Dim lambda3 As Double = 1.0 - lambda1 - lambda2

        ' 计算插值高程
        Dim elevation As Double = lambda1 * z1 + lambda2 * z2 + lambda3 * z3

        Return elevation
    End Function

    ' 判断点是否在三角形内
    Function IsPointInTriangle(vertices As Point3dCollection, point As Point3d) As Boolean
        Dim x1 As Double = vertices(0).X
        Dim y1 As Double = vertices(0).Y

        Dim x2 As Double = vertices(1).X
        Dim y2 As Double = vertices(1).Y

        Dim x3 As Double = vertices(2).X
        Dim y3 As Double = vertices(2).Y

        Dim x As Double = point.X
        Dim y As Double = point.Y

        Dim denominator As Double = ((y2 - y3) * (x1 - x3) + (x3 - x2) * (y1 - y3))
        Dim a As Double = ((y2 - y3) * (x - x3) + (x3 - x2) * (y - y3)) / denominator
        Dim b As Double = ((y3 - y1) * (x - x3) + (x1 - x3) * (y - y3)) / denominator
        Dim c As Double = 1 - a - b

        ' 检查点是否在三角形内
        Return 0 <= a AndAlso a <= 1 AndAlso 0 <= b AndAlso b <= 1 AndAlso 0 <= c AndAlso c <= 1
    End Function

    ' 在图上生成点和文本
    Sub CreatePointAndText(db As Database, tr As Transaction, point As Point3d, elevation As Double)
        Dim bt As BlockTable = CType(tr.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
        Dim btr As BlockTableRecord = CType(tr.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)

        ' 创建点对象
        Dim dbPoint As New DBPoint(point) With {
            .ColorIndex = 1 ' 红色
            }
        AppendEntity(dbPoint)

        ' 创建文本对象
        Dim text As New DBText With {
            .Position = New Point3d(point.X, point.Y, point.Z + 0.5), ' 将文本位置稍微偏高
            .TextString = elevation.ToString("F2"),
            .Height = 1.0,
            .ColorIndex = 2 ' 黄色
            }
        AppendEntity(text)

    End Sub

End Module

bskidtf

应该加上四叉树，不然会很影响速度，就没啥实际意义了