查找并绘制三角网边界

quickmap

Structure sjwxyh
        Dim pt0 As Point2d
        Dim pt1 As Point2d
        Dim pt2 As Point2d
        Dim id As ObjectId
    End Structure

   Structure sjwbjA
        Dim startpt As Point2d
        Dim endpt As Point2d
        Dim yn As Boolean
    End Structure

   Structure TypePointRectPoint    '有关点分区的变量定义
        Dim a() As Integer    '点序号列表
        Dim Count As Integer    '个数
    End Structure

<CommandMethod("sjwbj")> _
    Public Sub sjwbj()
        '查找三角网界并绘制边界线
        Dim dx As Integer, dy As Integer, Center_X() As Double, Center_Y() As Double, total_I() As Integer, RectL As Integer, RectPoint(,) As TypePointRectPoint, minx As Double, miny As Double, maxx As Double, maxy As Double
        Dim AreaPLine() As sjwxyh, ent As Entity, i As Integer, j As Integer, T0 As Integer, k As Integer, total As Integer, m As Integer, n As Integer, pl3d As Polyline3d, l As Integer, blc As Double, TypValAr(1) As TypedValue, SelFtr As SelectionFilter, SSPrompt As PromptSelectionResult
        Dim DB As Database = Application.DocumentManager.MdiActiveDocument.Database
        Dim DocED As Editor = Application.DocumentManager.MdiActiveDocument.Editor
        blc = Application.GetSystemVariable("ltscale")
        TypValAr.SetValue(New TypedValue(0, "Polyline"), 0)
        TypValAr.SetValue(New TypedValue(8, "SJW"), 1)     ‘指定三角网所在图层
        SelFtr = New SelectionFilter(TypValAr)
        SSPrompt = DocED.SelectAll(SelFtr)
        If SSPrompt.Status = PromptStatus.OK Then
            l = SSPrompt.Value.Count - 1
            ReDim AreaPLine(l)
            l = -1
            Using Trans As Transaction = DB.TransactionManager.StartTransaction()
                Dim btr As BlockTableRecord = Trans.GetObject(DB.CurrentSpaceId, OpenMode.ForWrite)
                For Each id As ObjectId In SSPrompt.Value.GetObjectIds
                    ent = Trans.GetObject(id, OpenMode.ForWrite)
                    If ent.GetType.Name = "Polyline3d" Then
                        pl3d = TryCast(ent, Polyline3d)
                        l = l + 1
                        n = 0
                        For Each id0 As ObjectId In pl3d
                            Dim pt As PolylineVertex3d = Trans.GetObject(id0, OpenMode.ForRead)
                            If pt.VertexType <> Vertex3dType.FitVertex Then
                                Select Case n
                                    Case 0
                                        AreaPLine(l).pt0 = New Point2d(pt.Position.X, pt.Position.Y)
                                    Case 1
                                        AreaPLine(l).pt1 = New Point2d(pt.Position.X, pt.Position.Y)
                                    Case 2
                                        AreaPLine(l).pt2 = New Point2d(pt.Position.X, pt.Position.Y)
                                End Select
                                n = n + 1
                                If n > 2 Then Exit For
                            End If
                        Next
                    End If
                Next
                If l > 0 Then
                    ReDim Preserve AreaPLine(l)
                    total = l * 3 + 2
                    ReDim Center_X(total), Center_Y(total), total_I(total)
                    For T0 = l To 0 Step -1
                        i = T0 * 3
                        j = i + 1
                        k = j + 1
                        With AreaPLine(T0)
                            Center_X(i) = (.pt0.X + .pt1.X) / 2
                            Center_X(j) = (.pt1.X + .pt2.X) / 2
                            Center_X(k) = (.pt2.X + .pt0.X) / 2
                            Center_Y(i) = (.pt0.Y + .pt1.Y) / 2
                            Center_Y(j) = (.pt1.Y + .pt2.Y) / 2
                            Center_Y(k) = (.pt2.Y + .pt0.Y) / 2
                        End With
                        total_I(i) = -1
                        total_I(j) = -1
                        total_I(k) = -1
                    Next T0

                    Dim PointNum As Double = 100 '控制分区大小及运算速度
                    minx = 10 ^ 10
                    miny = 10 ^ 10
                    maxx = -10 ^ 10
                    maxy = -10 ^ 10
                    For i = 0 To total
                        If Center_X(i) < minx Then minx = Center_X(i)
                        If Center_Y(i) < miny Then miny = Center_Y(i)
                        If Center_X(i) > maxx Then maxx = Center_X(i)
                        If Center_Y(i) > maxy Then maxy = Center_Y(i)
                    Next i
                    RectL = ((maxx - minx) + (maxy - miny)) / 3.5 / Math.Sqrt(total / PointNum)
                    m = Int((maxx - minx) / RectL)
                    n = Int((maxy - miny) / RectL)
                    ReDim RectPoint(m, n)
                    For i = 0 To total    '分区
                        m = Int((Center_X(i) - minx) / RectL)
                        n = Int((Center_Y(i) - miny) / RectL)
                        With RectPoint(m, n)
                            .Count = .Count + 1
                            ReDim Preserve .a(.Count)
                            .a(.Count) = i
                        End With
                    Next i

                    For i = 0 To total
                        If total_I(i) = -1 Then
                            dx = Int((Center_X(i) - minx) / RectL)
                            dy = Int((Center_Y(i) - miny) / RectL)
                            With RectPoint(dx, dy)
                                For T0 = .Count To 0 Step -1
                                    j = .a(T0)
                                    If total_I(j) = -1 Then
                                        If Math.Abs(Center_X(i) - Center_X(j)) < 0.0001 And Math.Abs(Center_Y(i) - Center_Y(j)) < 0.0001 Then
                                            If Int(j / 3) <> Int(i / 3) Then    '非本三角形
                                                total_I(i) = j
                                                total_I(j) = i
                                            End If
                                        End If
                                    End If
                                Next T0
                            End With
                        End If
                    Next i
                    Dim bb2() As sjwbjA, mn As Integer
                    ReDim bb2(0)
                    mn = -1
                    For i = 0 To total
                        If total_I(i) < 0 Then
                            j = Int(i / 3)
                            k = i Mod 3
                            Select Case k
                                Case 0
                                    mn += 1
                                    ReDim Preserve bb2(mn)
                                    bb2(mn).startpt = AreaPLine(j).pt0
                                    bb2(mn).endpt = AreaPLine(j).pt1
                                    bb2(mn).yn = True
                                Case 1
                                    mn += 1
                                    ReDim Preserve bb2(mn)
                                    bb2(mn).startpt = AreaPLine(j).pt1
                                    bb2(mn).endpt = AreaPLine(j).pt2
                                    bb2(mn).yn = True
                                Case 2
                                    mn += 1
                                    ReDim Preserve bb2(mn)
                                    bb2(mn).startpt = AreaPLine(j).pt2
                                    bb2(mn).endpt = AreaPLine(j).pt0
                                    bb2(mn).yn = True
                                Case Else
                            End Select
                        End If
                    Next
                    If mn > 0 Then
                        Dim pts As Point2dCollection, yn As Boolean
                        For i = 0 To mn - 1     '边界连接，有可能出现多条
                            pts = New Point2dCollection
                            If bb2(i).yn Then
                                pts.Add(bb2(i).startpt)
                                pts.Add(bb2(i).endpt)
                                m = 1
                                bb2(i).yn = False
                                Do
                                    yn = True
                                    For j = i + 1 To mn
                                        If bb2(j).yn And (pts.Item(m) = bb2(j).endpt Or pts.Item(m) = bb2(j).startpt) Then
                                            If pts.Item(m) = bb2(j).endpt Then  '尾相连则接头
                                                m = m + 1
                                                pts.Add(bb2(j).startpt)
                                                bb2(j).yn = False
                                            Else
                                                m = m + 1
                                                pts.Add(bb2(j).endpt)
                                                bb2(j).yn = False
                                            End If
                                            yn = False
                                            Exit For
                                        End If
                                    Next j
                                    If yn Then Exit Do '遍历所有未使用的边后无法连接则此环结束
                                Loop
                                n = pts.Count
                                If n > 1 Then
                                    Dim lw As Polyline = New Polyline
                                    For k = 0 To m
                                        lw.AddVertexAt(k, New Point2d(pts.Item(k).X, pts.Item(k).Y), 0, 0, 0)
                                    Next
                                    lw.ColorIndex = 1
                                    lw.Layer = "0"
                                    btr.AppendEntity(lw)
                                    Trans.AddNewlyCreatedDBObject(lw, True)
                                End If
                            End If
                        Next i
                    End If
                End If
                Trans.Commit()
            End Using
        End If
        Application.DocumentManager.MdiActiveDocument.SendStringToExecute(Chr(27), False, False, False)
    End Sub

quickmap

不知道怎么上传图片

xdcad2019

牛牛牛牛牛牛牛

dnbcgrass

请问楼主，有没有C#版的？