三角网及绘等高线函数

[转帖]三角网及绘等高线函数','0','数据结构：

Private Const M_Count_Const = 100 '初始分配内存
Private Const M_Point_Const = 20 '初始两排点分配内存

Private Type Line '自定义类型
X() As Single 'x坐标列
Y() As Single 'y坐标列
Count As Long '当前个数
M_Count As Long '已分配内存个数
End Type

Private Type Line_two '自定义类型
Line1() As Line '第一条线列（正向）
Line2() As Line '第二条线列（反向）
H() As Single '等高线高程列
OfFang() As Long '状态列:关闭,开放
Count As Long '当前个数
M_Count As Long '已分配内存个数
End Type

Private Max_line As Line_two '全部等高线定义', ,'本函数需联三角网时调用。
建立三角网后，实际上仅获得三角网三个顶点的坐标。为了绘等高线，还必须找出判断每边上是否有等高线高程点。通过两点直线线性高程内插法获得坐标点。每个三角网中同一高程等值点为两个时则可调用本主要入口函数。其中（x1,x2）、（x2,y2）为两个等值点，Ｈ为该两点高程。

主要入口函数：（唯一入口）
Private Sub AddLineMain(x1 As Single, y1 As Single, x2 As Single, y2 As Single, H As Single)

If TextBox_Hight2 <> "" Then If H > TextBox_Hight2 Then Exit Sub '附加的
If TextBox_Low2 <> "" Then If H < TextBox_Low2 Then Exit Sub '附加的

'增加三角内一小线段
Dim T_long As Long '临时
Dim line1_x As Single '临时
Dim line1_y As Single '临时
Dim line2_x As Single '临时
Dim line2_y As Single '临时

Dim T1_M As Long '临时
Dim T2_M As Long '临时

With Max_line
For T_long = 0 To .Count '循环全部已存等高线
If .H(T_long) = H Then '高程相等
If .OfFang(T_long) = 0 Then '开关
line1_x = .Line1(T_long).X(.Line1(T_long).Count) '临时变量
line1_y = .Line1(T_long).Y(.Line1(T_long).Count) '临时变量
line2_x = .Line2(T_long).X(.Line2(T_long).Count) '临时变量
line2_y = .Line2(T_long).Y(.Line2(T_long).Count) '临时变量

If x1 = line1_x And y1 = line1_y Then '判断端点
Call AddLine1Piont(x2, y2, T_long) '第一段正向加一个点
Call AddLineMain2(x2, y2, H, T_long, 1) '寻合并项
GoTo out
End If

If x2 = line1_x And y2 = line1_y Then '判断端点
Call AddLine1Piont(x1, y1, T_long) '第一段正向加一个点
Call AddLineMain2(x1, y1, H, T_long, 1) '寻合并项
GoTo out
End If

If x1 = line2_x And y1 = line2_y Then '判断端点
Call AddLine2Piont(x2, y2, T_long) '第二段反向加一个点
Call AddLineMain2(x2, y2, H, T_long, 2) '寻合并项
GoTo out
End If

If x2 = line2_x And y2 = line2_y Then '判断端点
Call AddLine2Piont(x1, y1, T_long) '第二段反向加一个点
Call AddLineMain2(x1, y1, H, T_long, 2) '寻合并项
GoTo out

End If
End If
End If
Next T_long
End With

'当没有相同的高程段,和要增加的一段两端点有相同点时,就增加一个等高段
Call AddLine(x1, y1, x2, y2, H) '增加一个等高段
Exit Sub
out:
'当增加的线段合并后,判断是否是闭合的等高线
With Max_line

T1_M = .Line1(T_long).Count
T2_M = .Line2(T_long).Count

If .Line2(T_long).X(T2_M) = .Line1(T_long).X(T1_M) Then '两端点X
If .Line2(T_long).Y(T2_M) = .Line1(T_long).Y(T1_M) Then '两端点y
.OfFang(T_long) = 1 '闭合
End If
End If

End With

End Sub
'Private Sub AddLine1Piont(X As Single, Y As Single, t As Long)
'正向(第一段)加一个点
Dim T_Count As Long
With Max_line

.Line1(t).Count = .Line1(t).Count + 1
T_Count = .Line1(t).Count

If T_Count > .Line1(t).M_Count Then '现有点数大于分配内存点数
.Line1(t).M_Count = .Line1(t).M_Count + .Line1(t).M_Count '加一倍内存
Dim N_L As Long
N_L = .Line1(t).M_Count
ReDim Preserve .Line1(t).X(N_L) '重定义内存
ReDim Preserve .Line1(t).Y(N_L) '重定义内存
End If

.Line1(t).X(T_Count) = X '加一个点x
.Line1(t).Y(T_Count) = Y '加一个点y

End With
End Sub

 

Private Sub AddLine2Piont(X As Single, Y As Single, t As Long)
'反向(第二段)加一个点
Dim T_Count As Long
With Max_line

.Line2(t).Count = .Line2(t).Count + 1
T_Count = .Line2(t).Count

If T_Count > .Line2(t).M_Count Then '现有点数大于分配内存点数
.Line2(t).M_Count = .Line2(t).M_Count + .Line2(t).M_Count '加一倍内存
Dim N_L As Long
N_L = .Line2(t).M_Count

ReDim Preserve .Line2(t).X(N_L) '重定义内存
ReDim Preserve .Line2(t).Y(N_L) '重定义内存
End If
.Line2(t).X(T_Count) = X '加一个点x
.Line2(t).Y(T_Count) = Y '加一个点y

End With
End Sub' ,'Private Sub AddLineMain2(X As Single, Y As Single, H As Single, T_long2 As Long, T2 As Long)
'搜索其它等高线段是否有可联接的等高线段（也就是另等高线段端点与新增加点为同一点）（另一种说法是相临三角形判断）
Dim T_long As Long
With Max_line
Dim F1 As Long
Dim F2 As Long
Dim Cass_Text As AcadText
Dim Point_xyh(2) As Single
Dim T_long3 As Long '临时可
Dim T1_M As Long '临时
Dim T2_M As Long '临时
Dim T3_M As Long '临时
Dim T4_M As Long '临时

 

For T_long = 0 To .Count
If .OfFang(T_long) = 0 Then '若是开放的
If H = .H(T_long) Then '相同高程
If T_long <> T_long2 Then '非本段
T1_M = .Line1(T_long).Count
T2_M = .Line2(T_long).Count
If Abs((X - .Line1(T_long).X(T1_M))) < 0.001 And Abs((Y - .Line1(T_long).Y(T1_M))) < 0.001 Then
T3_M = .Line1(T_long2).Count
T4_M = .Line2(T_long2).Count
If T2 = 1 Then
If (T1_M + T2_M) > (T3_M + T4_M) Then
For F1 = T3_M - 1 To 0 Step -1
Call AddLine1Piont(.Line1(T_long2).X(F1), .Line1(T_long2).Y(F1), T_long) '第一段正向加一个点
Next F1

For F1 = 0 To T4_M
Call AddLine1Piont(.Line2(T_long2).X(F1), .Line2(T_long2).Y(F1), T_long) '第一段正向加一个点
Next F1
.OfFang(T_long2) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
Else
For F1 = T1_M - 1 To 0 Step -1
Call AddLine1Piont(.Line1(T_long).X(F1), .Line1(T_long).Y(F1), T_long2) '第一段正向加一个点
Next F1

For F1 = 0 To T2_M
Call AddLine1Piont(.Line2(T_long).X(F1), .Line2(T_long).Y(F1), T_long2) '第一段正向加一个点
Next F1
.OfFang(T_long) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
End If
Else
If (T1_M + T2_M) > (T3_M + T4_M) Then
For F1 = T4_M - 1 To 0 Step -1
Call AddLine1Piont(.Line2(T_long2).X(F1), .Line2(T_long2).Y(F1), T_long) '第一段正向加一个点
Next F1

For F1 = 0 To T3_M
Call AddLine1Piont(.Line1(T_long2).X(F1), .Line1(T_long2).Y(F1), T_long) '第一段正向加一个点
Next F1
.OfFang(T_long2) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
Else
For F1 = T1_M - 1 To 0 Step -1
Call AddLine2Piont(.Line1(T_long).X(F1), .Line1(T_long).Y(F1), T_long2) '第2段正向加一个点
Next F1

For F1 = 0 To T2_M
Call AddLine2Piont(.Line2(T_long).X(F1), .Line2(T_long).Y(F1), T_long2) '第2段正向加一个点
Next F1
.OfFang(T_long) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
End If
End If
End If
If Abs(X - .Line2(T_long).X(T2_M)) < 0.001 And Abs(Y - .Line2(T_long).Y(T2_M)) < 0.001 Then
T3_M = .Line1(T_long2).Count
T4_M = .Line2(T_long2).Count
If T2 = 1 Then
If (T1_M + T2_M) > (T3_M + T4_M) Then
For F1 = T3_M - 1 To 0 Step -1
Call AddLine2Piont(.Line1(T_long2).X(F1), .Line1(T_long2).Y(F1), T_long) '第2段正向加一个点
Next F1

For F1 = 0 To T4_M
Call AddLine2Piont(.Line2(T_long2).X(F1), .Line2(T_long2).Y(F1), T_long) '第2段正向加一个点
Next F1
.OfFang(T_long2) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
Else
For F1 = T2_M - 1 To 0 Step -1
Call AddLine1Piont(.Line2(T_long).X(F1), .Line2(T_long).Y(F1), T_long2) '第一段正向加一个点
Next F1

For F1 = 0 To T1_M
Call AddLine1Piont(.Line1(T_long).X(F1), .Line1(T_long).Y(F1), T_long2) '第一段正向加一个点
Next F1
.OfFang(T_long) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
End If
Else
If (T1_M + T2_M) > (T3_M + T4_M) Then
For F1 = T4_M - 1 To 0 Step -1
Call AddLine2Piont(.Line2(T_long2).X(F1), .Line2(T_long2).Y(F1), T_long) '第一段正向加一个点
Next F1

For F1 = 0 To T3_M
Call AddLine2Piont(.Line1(T_long2).X(F1), .Line1(T_long2).Y(F1), T_long) '第一段正向加一个点
Next F1
.OfFang(T_long2) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
Else
For F1 = T2_M - 1 To 0 Step -1
Call AddLine2Piont(.Line2(T_long).X(F1), .Line2(T_long).Y(F1), T_long2) '第2段正向加一个点
Next F1

For F1 = 0 To T1_M
Call AddLine2Piont(.Line1(T_long).X(F1), .Line1(T_long).Y(F1), T_long2) '第2段正向加一个点
Next F1
.OfFang(T_long) = -1 '已被合并,本等高线段关闭,禁止
Exit Sub
End If
End If
End If
End If
End If
End If
Next T_long

End With

End Sub' ,
Private Sub AddLine(x1 As Single, y1 As Single, x2 As Single, y2 As Single, H As Single)
'新加一条等高线段
Dim T_long As Long
Dim T_Count As Long

With Max_line
T_Count = .Count
For T_long = 0 To T_Count '循环全部等高段找一个禁止的等高段
If .OfFang(T_long) = -1 Then '在原改一个等高段

.OfFang(T_long) = 0 '改开放

.H(T_long) = H '定义本段高程

.Line1(T_long).Count = 0 '现有点数初始为0
.Line1(T_long).X(0) = x2 '加点X
.Line1(T_long).Y(0) = y2 '加点y
.Line2(T_long).Count = 0 '现有点数初始为0
.Line2(T_long).X(0) = x1 '加点X
.Line2(T_long).Y(0) = y1 '加点y

Exit Sub
End If
Next T_long

'若没有禁止的高程式段则
'增加一个等高段
T_Count = T_Count + 1 '等高段计数加1
.Count = T_Count

If .Count >= .M_Count Then '现有等高段数大于分配内存等高段数
.M_Count = .Count + M_Count_Const '加 M_Count_Const 内存量
Dim N_L As Long
N_L = .M_Count
ReDim Preserve .H(N_L) '重定义内存
ReDim Preserve .Line1(N_L) '重定义内存
ReDim Preserve .Line2(N_L) '重定义内存
ReDim Preserve .OfFang(N_L) '重定义内存
End If

ReDim Preserve .Line1(T_Count).X(M_Point_Const) '重定义内存
ReDim Preserve .Line1(T_Count).Y(M_Point_Const) '重定义内存
ReDim Preserve .Line2(T_Count).X(M_Point_Const) '重定义内存
ReDim Preserve .Line2(T_Count).Y(M_Point_Const) '重定义内存

.H(T_Count) = H '定义本段高程
.Line1(T_Count).M_Count = M_Point_Const '现有等高段数初始为 M_Point_Const 段
.Line2(T_Count).M_Count = M_Point_Const '现有等高段数初始为 M_Point_Const 段

.Line1(T_Count).X(0) = x2 '初始化'加点X
.Line1(T_Count).Y(0) = y2 '初始化'加点y
.Line2(T_Count).X(0) = x1 '初始化'加点X
.Line2(T_Count).Y(0) = y1 '初始化'加点y
End With
End Sub', ,'归纳了一下:

连等高线
1。先标记每个三角形等高段，确定出高程相等的X1，Y1，X2，Y2两点

2。判断如果X1，Y1的高程在前面的三角形没出现过，那么LINE2（D）.X(0)=X1,LINE2（D）.Y(0)=Y1, LINE1（D）.X(0)=X2,LINE1（D）.Y(0)=Y2
否则判断当前的X1，Y1是否等于LINE1（）.X(),还是LINE2（）.X()，如果等于LINE1，那么LINE2(D).X(0+1)=X1,同理....

3. 利用AddLineMain2（）判断如果有两条等高线高程相同，但是断开的，那么把它们合为一条(多数情况是由递归产生的)

4. 总之，先定第一个三角形的等高段，把两点分别副给LINE1（），LINE2（）两点，以后的三角形中的相同高程段就可以判断两端点在LINE1，LINE2的哪一侧，再赋值。