按间接平差原理写的代码，绝对有用，真实可靠
Dim strFileName As String
Dim nn%, un%, tn%, hn% '已知点个数，未知点个数，总点数，观测值个数
Dim Pname() As String '点名数组
Dim Hknown() As Double '已知高程数组，存放已知点高程和高程近似值
Dim be%(), en%() '观测值的起点和终点编号数组，存储的是点序号
Dim h#(), s#() '高差观测值数组和距离观测值数组
Dim A#(), X#(), P#(), L#() '间接平差的系数阵、解向量、权阵和常数向量
'平差计算
Private Sub mnuAdj_Click()
Dim i%, j%
ReDim X(1 To un)
InAdjust A, P, L, X '调用间接平差的通用过程求解
'计算并显示高程平差结果
txtShow.Text = txtShow.Text & "平差计算结果：" & vbCrLf
txtShow.Text = txtShow.Text & "点号 初始高程(m) 高程改正数(m) 平差后高程(m)" & vbCrLf
For i = 1 To un
txtShow.Text = txtShow.Text & Pname(nn + i) & " " & Format(Hknown(nn + i), "0.0000")
Hknown(nn + i) = Hknown(nn + i) + X(i)
txtShow.Text = txtShow.Text & " " & Format(X(i), "0.0000") & " " & Format(Hknown(nn + i), "0.0000") & vbCrLf
Next i
txtShow.Text = txtShow.Text & vbCrLf
'计算并显示单位权中误差--------->>精度评定部分应该也包含在间接平差模块里，一起来调用
' Dim dblT As Double
' dblT = 0
' For i = 1 To un
'
' Next i
End Sub
'列立误差方程：给A、P、L赋值
Private Sub mnuEqu_Click()
Dim i%, j%
ReDim A(1 To hn, 1 To un), L(1 To hn), P(1 To hn, 1 To hn)
'对每个观测值列误差方程
For i = 1 To hn
If en(i) > nn Then A(i, en(i) - nn) = 1 '若终点未知，则给终点对应的系数矩阵元素赋值
If be(i) > nn Then A(i, be(i) - nn) = -1 '若起点未知，则给起点对应的系数矩阵元素赋值
L(i) = -(Hknown(en(i)) - Hknown(be(i)) - h(i)) '根据起终点计算常数项
P(i, i) = 1 / s(i) '以距离的倒数为权
Next i
'显示误差方程
txtShow.Text = txtShow.Text & " 列立的误差方程：" & vbCrLf
For i = 1 To hn
For j = 1 To un
txtShow.Text = txtShow.Text & A(i, j) & " "
Next j
txtShow.Text = txtShow.Text & " " & Format(L(i), "0.0000") & vbCrLf
Next i
txtShow.Text = txtShow.Text & "权矩阵：" & vbCrLf
For i = 1 To hn
For j = 1 To hn
txtShow.Text = txtShow.Text & P(i, j) & " "
Next j
txtShow.Text = txtShow.Text & vbCrLf
Next i
End Sub
'计算近似高程
Private Sub mnuHeight_Click()
Dim i%, j%
For i = 1 To un
For j = 1 To hn
If be(j) = nn + i And en(j) < nn + i Then '找到一个起点相同且终点已知的观测值
Hknown(nn + i) = Hknown(en(j)) - h(j)
Exit For
End If
If en(j) = nn + i And be(j) < nn + i Then '找到一个终点相同且起点已知的观测值
Hknown(nn + i) = Hknown(be(j)) + h(j)
Exit For
End If
Next j
Next i
'显示近似高程计算结果
txtShow.Text = txtShow.Text & " 近似高程计算结果： " & vbCrLf
For i = 1 To un
txtShow.Text = txtShow.Text & Pname(i + nn) & "：" & Format(Hknown(i + nn), "0.000") & vbCrLf
Next i
End Sub
'退出程序
Private Sub mnuExit_Click()
End
End Sub
'打开文件
Private Sub mnuOpen_Click()
Dim i As Integer '循环变量
Dim strT1 As String, strT2 As String
CDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"
CDg1.ShowOpen '打开对话框
strFileName = CDg1.FileName '获得选中的文件名和路径
Open strFileName For Input As #1 '打开文件
Input #1, nn, un, hn '读入已知点个数，未知点个数，观测值个数
tn = nn + un
ReDim Pname(1 To tn), Hknown(1 To tn)
ReDim h(1 To hn), s(1 To hn), be(1 To hn), en(1 To hn)
For i = 1 To tn '读入点名
Input #1, Pname(i)
Next i
For i = 1 To nn '读入已知高程
Input #1, Hknown(i)
Next i
For i = 1 To hn '读入各观测值
Input #1, strT1, strT2, h(i), s(i)
be(i) = Order(strT1): en(i) = Order(strT2) '给起终点数组排序
Next i
'显示读入的数据
txtShow.Text = txtShow.Text & "读入的水准网数据：" & vbCrLf
txtShow.Text = txtShow.Text & " 已知点" & nn & "个，未知点" & un & "个，观测值" & hn & "个。" & vbCrLf
txtShow.Text = txtShow.Text & " 网中涉及的点名有："
For i = 1 To tn
txtShow.Text = txtShow.Text & Pname(i) & "，"
Next i
txtShow.Text = txtShow.Text & vbCrLf
txtShow.Text = txtShow.Text & " 已知点高程为：" & vbCrLf
For i = 1 To nn
txtShow.Text = txtShow.Text & Pname(i) & "的高程为：" & Hknown(i) & vbCrLf
Next i
txtShow.Text = txtShow.Text & " 各观测值分别为：" & vbCrLf
txtShow.Text = txtShow.Text & "起点" & " " & "终点" & " " & "高差观测值 " & " 距离观测值" & vbCrLf
For i = 1 To hn
txtShow.Text = txtShow.Text & Pname(be(i)) & " " & Pname(en(i)) & " " & Format(h(i), "0.000") & " " & Format(s(i), "0.000") & vbCrLf
Next i
Close #1 '不要忘记关闭文件
End Sub
'点名－序号转换函数
Public Function Order(str As String) As Integer
Dim i%
For i = 1 To tn
If str = Pname(i) Then
Order = i
Exit For
End If
Next i
End Function
'保存计算结果
Private Sub mnuSave_Click()
CDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"
CDg1.ShowSave
strFileName = CDg1.FileName
Open strFileName For Output As #1
Print #1, txtShow.Text
Close #1
End Sub
5215
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
