四等水准附和导线、闭合导线平差VB代码

程序说明：
数据录入文件的存储格式为：按每一测站的距离、高差形式存储，平差之前需要输入测站总数，依次点击“平差计算”、“成果分析”、“成果输出“。

Dim ds() As Single, ht() As Single, detht() As Single, zh() As Single 'ht测量高差，deth高差改正数，zh点高程
Dim fht As Single, n As Integer, fr As Single, sds As Single 'fht高差闭合差，n测站数，fr高差闭差合限差，sds线路总长
Private Sub Command3_Click()
End
End Sub
Private Sub Command5_Click()
Dim i As Integer
n = Val
If n = 0 Then
MsgBox "请输入测站数"
Exit Sub
End If
ReDim ht(n) As Single, ds(n) As Single, detht(n) As Single, zh(n) As Single
= "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
strfilename =
Open strfilename For Input As #1
For i = 1 To n
Input #1, ds(i), ht(i)
If ds(i) > 160 Then
MsgBox "第" & i & "测站视距超限"
Exit Sub
End If
Next i
Close #1
MsgBox "数据已录入"
End Sub
Private Sub Command6_Click()
Dim i As Integer, sht As Single, x As Single
Dim a As Single, b As Single
sds = 0
sht = 0
For i = 1 To n
sds = sds + ds(i)
sht = sht + ht(i)
Next i
If Then
a = Val
b = Val
fht = sht - (a - b)
Else
If Then
a = Val
fht = sht
End If
End If
zh(0) = a
For i = 1 To n
x = -fht * ds(i) / sds
detht(i) = x
ht(i) = ht(i) + detht(i)
zh(i) = zh(i - 1) + ht(i) Next i
MsgBox "平差计算已完成" End Sub
Private Sub Command7_Click()
Dim x As Single
fr = 40 * Sqr(sds / 1000)
x = Abs(fht)
If x > fr Then
MsgBox "线路全长高差闭合差超限，但系统已按照平差原理平差，如需保存结果，请点击“成果保存”按钮"
Exit Sub
Else
MsgBox "线路全长高差闭合差符合限差要求，如需保存结果，请点击“成果保存”按钮"
End If
End Sub
Private Sub Command8_Click()
Dim i As Integer
= "文本文件(*.txt)|*.txt|所有文件(*.*)|*.*"
strfilename =
Open strfilename For Output As #2
For i = 1 To n
Print #2, "第" & i & "测站视线长：" & ds(i) & "m",
Print #2, "高差改正数：" & Format(detht(i), "") & "m",
Print #2, "改后高差：" & Format(ht(i), "") & "m",
Print #2, "高程：" & Format(zh(i), "") & "m"
Next i
Print #2, "路线全长：" & Format(sds / 1000, "") & "km"
Print #2, "路线全长高差闭合差：" & Format(fht, "") & "m"
Print #2, "限差：" & Format(fr / 1000, "") & "m" Print #2, "解算人：×××"
Print #2, "时间：" & Date
Close #2
MsgBox "成果已保存"
End Sub。