查找并绘制三角网边界
本帖最后由 quickmap 于 2021-2-24 16:27 编辑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 于 2021-2-24 16:24 编辑
不知道怎么上传图片
牛牛牛牛牛牛牛 请问楼主，有没有C#版的？
页:
[1]