水准网平差(VB代码)
VB测量平差程序设计讲稿
Case 0 '读入观测值文件Text1.Visible = FalseCommonDialog1.ShowOpenfname = CommonDialog1.FileName '将用户在"打开"对话框中选择的文件名对变量fname赋值If fname <> "" Then '若无此判断当对话框中选择取消时、下面赋值语句将出错Set ts = fso.OpenTextFile(fname) '将fname作为文本文件打开,并设置句柄j = 0: k = 0: p = 0: h = 0'j是测站数累计变量,k是已知点累计变量,l（j）、ns（j）分别是方向值、边长累积计数Do While ts.AtEndOfLine <> True '前测型循环，进入循环的条件是没有读到文件结束尾B = ts.ReadLine '读一行，置入bB = Trim(B): i = 1: '删除B可能有的前导和尾随空格，i是工作变量，m(i) = InStr(B, ",") '查行中第一个逗号的左数位置,并保存在整形数组变量m(i)Do While m(i) <> 0 '前测型Do... Loop循环，成立条件是该行字符串中有逗号tr(i) = Mid(B, m(i - 1) + 1, m(i) - m(i - 1) - 1) '提取指定位置开始的指定数目字符。
i = i + 1m(i) = InStr(m(i - 1) + 1, B, ",") '从上一个找到的逗号位置起，查找下一个逗号的位置LoopIf m(i) = 0 And i > 1 Then tr(i) = Right(B, Len(B) - m(i - 1)) '处理一行中最后一个逗号后的字符串'以下部分是将存储在数组变量m(i)中的字符分类存放到方向、边长、已知坐标、网型信息等数组中If p = 0 Then '读到的是文件第一行。
实验一matlab完成水准网平差
实验一matlab完成水准网平差实验一 matlab完成水准网平差实验数据：水准网有2个已知点，3个未知点，7个测段。
已知点高程H1=5.016M H2=6.016h1=1.359; h2=2.009; h3=0.363; h4=1.012; h5=0.657; h6=0.238; h7=-0.595;S1=1.1 S2=1.7 S3=2.3 S4=2.7 S5=2.4 S6=1.4 S7=2.6求解（1）求个待定点高程,H5的高差中误差；3、4号点的高程中误差。
课程设计内容1、平差程序设计思路：使用间接平差法求解（1）由题意知必要观测数t=3，选取3、4、5号点高程X1、X2、X3为参数。
（2）误差方程：V1=x1v2=x2v3=x1v4=x2v5=x2-x1+h2-h1-h5v6=x3-x1v7=-x3(3)取1M 的观测高程为单位权观测，即 p=1/s；(4)求法方程：Nbbx-W=0 Nbb=b’pbW=b’pl(5)求的平差值x=Nbb^-1*W L=l+V V=bx-l （6）高差权函数式：k=-x1+x2(6)求中误差：单位权中误差δ0，协因数阵Nbb^-1.求得中误差δ2、平差程序流程代码说明：h1=1.359;h2=2.009;h3=0.363;h4=1.012;h5=0.657;h6=0.238;h7=-0.595;H1=5.016H2=6.016h=[h1 h2 h3 h4 h5 h6 h7]'s=[1.1 1.7 2.3 2.7 2.4 1.4 2.6]'B=[1 0 0 ;0 1 0;1 0 0;0 1 0 ; -1 1 0 ; -1 0 1 ;0 0 -1 ] p=diag(1./s)l=[0;0;4;3;7;2;0]W=B'*p*lNbb=B'*p*Bx=inv(Nbb)*WV=(B*x-l)H=h+V/1000Q=inv(Nbb)n=7;t=3;j=V'*p*Vd= sqrt(j/4)f=[-1 1 0]'q=f'*Q*fD=d*sqrt(q)D1=d*sqrt(Q)(3) 平差程序流程代码说明: clc cleardisp(‘观测高差，单位m’)h1=1.359;h2=2.009;h3=0.363;h4=1.012;h5=0.657;h6=0.238;h7=-0.595;H1=5.016 % 已知点高程，单位mH2=6.016 % 已知点高程，单位mh=[h1 h2 h3 h4 h5 h6 h7]'s=[1.1 1.7 2.3 2.7 2.4 1.4 2.6]' %S是线路长度disp(‘系数矩阵B、l’)B=[1 0 0 ;0 1 0;1 0 0;0 1 0 ; -1 1 0 ;-1 0 1 ;0 0 -1 ]p=diag(1./s) %定义权阵l=[0;0;4;3;7;2;0]W=B'*p*lNbb=B'*p*Bdisp(‘参数的解’)x=inv(Nbb)*WV=(B*x-l) % 误差方程(mm)。
水准网平差(VB代码)
误差理论与测量平差础）课程设计报告系（部）：土木工程系实习单位：山东交通学院班级：测绘084学生姓名：田忠星学号080712420带队教师：夏小裕﹑周宝兴时间：10 年12 月13 日到10 年12 月19 日山东交通学院目录：1.摘要P32.概述P33.水准网间接平差程序设计思路P3—P44.平差程序流程图P4—P65.程序源代码及说明P7—P236.计算结果P23—P267.总结P26—P27一：摘要在测量工作中，为了能及时发现错误和提高测量成果的精度，常作多余观测，这就产生了平差问题。
在一个平差问题中，当所选的独立参数X?的个数等于必要观测数t 时，可将每个观测值表达成这t 个参数的函数，组成观测方程，这种以观测方程为函数模型的平差方法，就是间接平差。
二：概述：该课程设计的主要目是对水准网进行间接平差，在输入数据后依次计算高程近似值﹑误差方程和平差计算。
三：水准网间接平差程序设计思路1．根据平差问题的性质，选择t 个独立量（既未知点的高程）作为参数X?2.将每一个观测量的平差值（既观测的高程差值）分别表达成L L V3．由误差方程系数 B 和自由项组成法方程，法方程个数等于参数的个数t ；4. 解算法方程，求出参数X?,计算参数（高程）的平差值X?=X0 +x? ；5．由误差方程计算V，求出观测量（高差）平差值L L V 6.评定精度单位权中误差平差值函数的中误差四：平差程序流程图1． 已知数据的输入 需要输入的数据包括水准网中已知点数﹑未知点数以及这些点 的点号， 已知高程和高差观测值﹑距离观测值。
程序采用文件方 式进行输入，约定文件输入的格式如下： 第一行：已知点数﹑未知点数﹑观测值个数 第二行：点号（已知点在前，未知点在后） 第三行：已知高程（顺序与上一行的点号对应） 第四行：高差观测值，按“起点点号，终点点号。
高差观测值， 距离观测值”的顺序输入。
本节中使用的算例的数据格式如下2,3,7 1,2,3,4,5 5.016,6.016 1,3,1.359,1.11,4,2.009,1.7 2,3,0.363,2.3 2,4,1.012,2.7 3,4,0.657,2.4 3,5,0.238,1.4 5,2,-0.595,2.6 2.平差计算过程V TPV rV TPVnus（1）近似高程的计算。
水准网平差(VB代码)
（误差理论与测量平差础）课程设计报告系（部）：土木工程系实习单位：山东交通学院班级：测绘084学生姓名：田忠星学号********* 带队教师：夏小裕﹑周宝兴时间：10 年12 月13日到10 年12 月19日山东交通学院目录：1.摘要P32.概述P33.水准网间接平差程序设计思路P3—P44. 平差程序流程图P4—P65. 程序源代码及说明P7—P236. 计算结果P23—P267. 总结P26—P27一：摘要在测量工作中，为了能及时发现错误和提高测量成果的精度，常作多余观测，这就产生了平差问题。
在一个平差问题中，当所选的独立参数Xˆ的个数等于必要观测数t时，可将每个观测值表达成这t个参数的函数，组成观测方程，这种以观测方程为函数模型的平差方法，就是间接平差。
二：概述：该课程设计的主要目是对水准网进行间接平差，在输入数据后依次计算高程近似值﹑误差方程和平差计算。
三：水准网间接平差程序设计思路1．根据平差问题的性质，选择t个独立量（既未知点的高程）作为参数Xˆ2. 将每一个观测量的平差值（既观测的高程差值）分别表达成3．由误差方程系数B和自由项组成法方程，法方程个数等于参数的个数t ；4. 解算法方程，求出参数Xˆ,计算参数（高程）的平差值Xˆ=X0 +xˆ；5．由误差方程计算V，求出观测量(高差)平差值6.评定精度单位权中误差VLL+ =∧VLL+ =∧平差值函数的中误差四：平差程序流程图1． 已知数据的输入需要输入的数据包括水准网中已知点数﹑未知点数以及这些点的点号，已知高程和高差观测值﹑距离观测值。
程序采用文件方式进行输入，约定文件输入的格式如下：第一行：已知点数﹑未知点数﹑观测值个数第二行：点号（已知点在前，未知点在后）第三行：已知高程（顺序与上一行的点号对应）第四行：高差观测值，按“起点点号，终点点号。
高差观测值，距离观测值”的顺序输入。
本节中使用的算例的数据格式如下2,3,71,2,3,4,55.016,6.0161,3,1.359,1.11,4,2.009,1.7 2,3,0.363,2.3,ˆ20s u n PV V r PV V T T +-==σ.ˆˆˆ0ˆϕϕϕσσQ =2,4,1.012,2.73,4,0.657,2.43,5,0.238,1.45,2,-0.595,2.62.平差计算过程（1）近似高程的计算。
水准网的条件平差
云南旅游职业学院专科毕业（设计）论文目录目录 (1)观测误差 (2)摘要： (2)关键词: (2)引言 (3)1水准测量 (4)1.1水准测量的原理 (4)1.2水准网 (5)2条件平差 (6)2。
1衡量精度的指标 (6)2。
2条件平差的原理 (8)3水准网的平差 (14)3.1必要观测与多余观测 (14)3。
2条件方程 (14)3。
3条件平差法方程式 (15)3.4条件平差的精度评定 (15)3。
5水准网的条件平差 (18)致谢 (21)参考文献 (21)1云南旅游职业学院专科毕业（设计）论文观测误差—由观测者、外界环境引起的偶然误差学生： xxx 指导教师：xxx摘要:对一系列带有偶然误差的观测值，采用合理的的方法消除它们间的不符值，得出未知量的最可靠值；以及评定测量成果的精度.关键词：偶然误差；观测值；精度2云南旅游职业学院专科毕业（设计）论文引言测量工作中，要确定地面点的空间位置，就必须进行高程测量，确定地面点的高程。
几何水准测量是高程测量中最基本、最精密的一种方法。
通过测量仪器，工具等任何手段获得的以数字形式表示的空间信息，即观测量。
然而，测量是一个有变化的过程，受仪器、观测值、外界环境因素的影响，观测的结果与客观上存在的一个能反映其真正大小的数值,即真值（理论值），有一定的差异。
可以说在测量中产生误差是不可避免的.所以，观测值不能准确得到，在测量上称这种差异为观测误差。
根据其对观测结果影响的性质，可将误差分为系统误差和偶然误差两种。
前者可以通过在观测过程中采取一定的措施和在观测结果中加入改正数，消除或减弱它的影响，使其达到忽略不计的程度。
但是，观测结果中，不可避免地包含了后者,它是不可消除的，但可以选择较好的观测条件或采用适当的数据处理方法减弱它。
现在我们要讨论的就是采用适当的数据处理方法来减弱其对水准测量中的影响。
3云南旅游职业学院专科毕业（设计）论文41 水准测量1。
1 水准测量的原理1。
水准网条件平差.
10
10
ˆ hˆ ： （11）计算 P1 至 P2 点观测高差平差值的精度 12
ˆ h ˆ 式，得其权函数式系数 f T 0 0 1 0，则： 由 2 h 2 P P 3 1 2
'T ˆh ˆ ˆ Q f ˆ ˆL ˆ f 2 0.39 0.86 0.36m m 0 0 2 QL
2 1 k a 0 0 1 4 k b 1 0解 Nhomakorabea法方程得：
k a 0.14 K k b 0.29
7
7
（4）计算改正数，由V P 1 AT K 可计算得到
V 0.14 0.14 0.57 0.29
2
ˆ P： （10）计算 P2点高程平差值的中误差
ˆ 式，可得权函数系数 f T 0 0 0 1，则： ˆ H h 由 1 H 1 2 C 4
ˆP ˆ 0 Q ˆ 0 f1T QL ˆL ˆ f1 0.39 0.71 0.33m m
2 1 1
,则
0 1 0 0
0 0 2 0
0 0 0 1
（3）法方程的组成与解算。
组成法方程
AP1 AT K W 0
1 1 1 0 0 0 0 1 1 1 0 0
6
0 1 0 0
0 0 2 0
6
0 1 0 1 1 k 0 a 0 0 1 k 0 0 1 b 1 0 1
V T PV 0.29 2 ˆ 0.15m m r 2
2 0
2 ˆ0 ˆ0 0.39 mm
9
9
（9）计算观测值平差的协因数：
vb水准
导线测量平差水准测量平差VB程序导线测量, 水准测量, 程序符合导线平差程序如下：Const pi As Double = 3.14159265358979 Private Sub Command1_Click() Form8.Hide mj = Val(Text1.Text) If list1.Text = "等精度" Then ma = Val(Text2.Text) mb = Val(Text3.Text) End If If Opt1.Value Then ij = 1 ElseIf Opt2.V alue Then ij = Val(Text4.Text) End If CommonDialog1.ShowOpen On Error GoTo errorhandler Open CommonDialog1.FileName For Input As #1 If Form8.Caption = "闭合导线" Then Input #1, bi1, bi2 End If Dim a1() Do n1 = n1 + 1 ReDim Preserve a1(1 To n1) Input #1, a1(n1) Loop Until Left(a1(n1), 1) = "*" n1 = (n1 - 1) / 3 ReDim Preserve a1(1 To 3 * n1) Dim c() Do t = t + 1 ReDim Preserve c(1 To t) Input #1, c(t) Loop Until Left(c(t), 1) = "*" t = t - 1 ReDim Preserve c(1 To t) Dim b1() If list1.Text = "等精度" Then '等精度时，取角度和距离观测值Do n2 = n2 + 1 ReDim Preserve b1(1 To n2) Input #1, b1(n2) Loop Until Left(b1(n2), 1) = "*" n2 = (n2 - 1) / 4 ReDim Preserve b1(1 To 4 * n2) Dim d1() Do While Not EOF(1) n3 = n3 + 1 ReDim Preserve d1(1 To n3) Input #1, d1(n3) Loop n3 = n3 / 3 ElseIf list1.Text = "不等精度" Then '不等精度时，取角度和距离观测值以及中误差Dim b5() Do n2 = n2 + 1 ReDim Preserve b1(1 To 4 * n2), b5(1 To n2) Input #1, b1(4 * n2 - 3), b1(4 * n2 - 2), b1(4 * n2 - 1), b1(4 * n2), b5(n2) Loop Until Left(b1(4 * n2 - 3), 1) = "*" Dim d4() ReDim d1(1 To 3), d4(1 To 1) d1(1) = b1(4 * n2 - 2): d1(2) = b1(4 * n2 - 1) d1(3) = b1(4 * n2): d4(1) = b5(n2) n2 = n2 - 1 ReDim Preserve b1(1 To 4 * n2), b5(1 To n2) n3 = n3 + 1 Do While Not EOF(1) n3 = n3 + 1 ReDim Preserve d1(1 To 3 * n3), d4(1 To n3) Input #1, d1(3 * n3 - 2), d1(3 * n3 - 1), d1(3 * n3), d4(n3) Loop End If Close #1 n6 = 0 Dim ax1() If Form8.Caption = "附有条件的导线网" Then '如是附有条件的导线，取条件CommonDialog1.ShowOpen Open CommonDialog1.FileName For Input As #2 Do While Not EOF(2) n6 = n6 + 1 ReDim Preserve ax1(1 To n6) Input #2, ax1(n6) Loop n6 = n6 / 4 Close #2 End If For i = 1 To n2 If b1(4 * i - 3) Like b1(4 * i - 2) Or b1(4 * i - 3) Like b1(4 * i - 1) Or b1(4 * i - 2) Like b1(4 * i - 1) Then MsgBox "角度观测中，第" & i & "行存在重复点名！", , "错误" Exit Sub End If Next For i = 1 To n3 If d1(3 * i - 2) Like d1(3 * i - 1) Then MsgBox "边长观测中，第" & i & "行存在重复点名！", , "错误" Exit Sub End If Next Dim b11(), d11() ReDim b11(1 To 4 * n2), d11(1 To 3 * n3) For i = 1 To n2 For i1 = 1 To t If b1(4 * i - 3) Like c(i1) Then b11(4 * i - 3) = i1 + n1 GoTo 1 End If Next For i1 = 1 To n1 If b1(4 * i - 3) Like a1(3 * i1 - 2) Then b11(4 * i - 3) = i1 GoTo 1 End If Next int8 = MsgBox("角度观测中，第" & i & "行存在错误测站点" & b1(4 * i - 3) & "！", , "错误！") If int8 = vbOK Then Exit Sub 1: For i1 = 1 To t If b1(4 * i - 2) Like c(i1) Then b11(4 * i - 2) = i1 + n1 GoTo 2 End If Next For i1 = 1 To n1 If b1(4 * i - 2) Like a1(3 * i1 - 2) Then b11(4 * i - 2) = i1 GoTo 2 End If Next int8 = MsgBox("角度观测中，第" & i & "行存在错误后视点" & b1(4 * i - 2) & "！", , "错误！") If int8 = vbOK Then Exit Sub 2: For i1 = 1 To t If b1(4 * i - 1) Like c(i1) Then b11(4 * i - 1) = i1 + n1 GoTo 3 End If Next For i1 = 1 To n1 If b1(4 * i - 1) Like a1(3 * i1 - 2) Then b11(4 * i - 1) = i1 GoTo 3 End If Next int8 = MsgBox("角度观测中，第" & i & "行存在错误前视点" & b1(4 * i - 1) & "！", , "错误！") If int8 = vbOK Then Exit Sub 3: b11(4 * i) = b1(4 * i) Next For i = 1 To n3 For i1 = 1 To t If d1(3 * i - 2) Like c(i1) Then d11(3 * i - 2) = i1 + n1 GoTo 4 End If Next For i1 = 1 To n1 If d1(3 * i - 2) Like a1(3 * i1 - 2) Then d11(3 * i - 2) = i1 GoTo 4 End If Next int8 = MsgBox("边长观测中，第" & i & "行存在错误点" & d1(3 * i - 2) & "！", , "错误！") If int8 = vbOK Then Exit Sub 4: For i1 = 1 To t If d1(3 * i - 1) Like c(i1) Then d11(3 * i - 1) = i1 + n1 GoTo 5 End If Next For i1 = 1 To n1 If d1(3 * i - 1) Like a1(3 * i1 - 2) Then d11(3 * i - 1) = i1 GoTo 5 End If Next int8 = MsgBox("边长观测中，第" & i & "行存在错误点" & d1(3 * i - 1) & "！", , "错误！") If int8 = vbOK Then Exit Sub 5: d11(3 *i) = d1(3 * i) Next Dim x0() If Form8.Caption = "附合导线" Then ReDim x0(1 To 2 * t + 2) x0() = 附合导线(a1(), b11(), d11(), t) fx = x0(2 * t + 1) '坐标闭合差fy = x0(2 * t + 2) fs = Sqr(fx * fx + fy * fy) fx = Format(fx * 100, "0.0") fy = Format(fy * 100, "0.0") s = 0 For i = 1 To n3 '全长相对闭合差s = s + d1(3 * i) Next fs = Int(s / fs) For i = 1 To n2 '方位闭合差If b11(4 * i - 3) <= n1 And b11(4 * i - 2) <= n1 Then i1 = b11(4 * i - 3): i2 = b11(4 * i - 2) x1 = a1(3 * i1 - 1): y1 = a1(3 * i1) x2 = a1(3 * i2 - 1): y2 = a1(3 * i2) aq = xlu(x2, y2, x1, y1) ElseIf b11(4 * i - 3) <= n1 And b11(4 * i - 1) <= n1 Then i1 = b11(4 * i - 3): i2 = b11(4 * i - 1) x1 = a1(3 * i1 - 1): y1 = a1(3 * i1) x2 = a1(3 * i2 - 1): y2 = a1(3 * i2) az = xlu(x1, y1, x2, y2) End If bb = bb + hu(b1(4 * i)) Next bb = (aq + bb - n2 * pi - az) * 206264.806247096 bb = Format(bb, "0.00") bb1 = mj * Sqr(n2) bb1 = Format(bb1, "0.00") ReDim Preserve x0(1 To 2 * t) ElseIf Form8.Caption = "闭合导线" Then ReDim x0(1 To 2 * t + 2) x0() = 附合导线(a1(), b11(), d11(), t) fx = x0(2 * t + 1) '坐标闭合差fy = x0(2 * t + 2) fs = Sqr(fx * fx + fy * fy) fx = Format(fx * 100, "0.0") fy = Format(fy * 100, "0.0") s = 0 For i = 1 To n3 s = s + d1(3 * i) Next fs = Int(s / fs) For i = 1 To n2 bb = bb + hu(b1(4 * i)) Next If bi1 = 0 Then '方位闭合差If bi2 = 0 Then bb = (bb - (n2 - 2) * pi) * 206264.806247096 ElseIf bi2 = 1 Then bb = (bb - (n2 + 2) * pi) * 206264.806247096 End If ElseIf bi1 = 1 Then For i = 1 To n2 If b11(4 * i - 3) <= n1 And b11(4 * i - 2) <= n1 Then i1 = b11(4 * i - 3): i2 = b11(4 * i - 2) x1 = a1(3 * i1 - 1): y1 = a1(3 * i1) x2 = a1(3 * i2 - 1): y2 = a1(3 * i2) aq = xlu(x2, y2, x1, y1) End If Exit For Next If bi2 = 0 Then bb = (bb - aq - (n2 - 3) * pi) * 206264.806247096 ElseIf bi2 = 1 Then bb = (bb - aq - (n2 + 1) * pi) * 206264.806247096 End If End If bb1 = mj * Sqr(n2) bb1 = Format(bb1, "0.00") ReDim Preserve x0(1 To 2 * t) ElseIf Form8.Caption = "导线网平差" Then ReDim ax1(0) ReDim x0(1 To 2 * t) x0() = 导线网(a1(), b11(), d11(), ax1(), t) Else ReDim x0(1 To 2 * t) x0() = 导线网(a1(), b11(), d11(), ax1(), t) End If mj1 = mj For ii = 1 To ij Dim b2(), l2(), p() ReDim Preserve b2(1 To n2, 1 To 2 * t), l2(1 To n2), p(1 To n2 + n3) l2() = 角常系数1(a1(), b11(), x0()) b2() = 方系数2(a1(), b11(), x0()) Dim b3(), l3() ReDim b3(1 To n3, 1 To 2 * t), l3(1 To n3) b3() = 边系数2(a1(), d11(), x0()) l3() = 边常数项1(a1(), d11(), x0()) Dim b(), l() ReDim Preserve b(1 To n2 + n3, 2 * t), l(1 To n2 + n3) For j = 1 To 2 * t For i = 1 To n2 If b2(i, j) = "" Then b2(i, j) = 0 End If b(i, j) = 10 ^ 4 * b2(i, j) / 206264.806247096 If list1.Text = "等精度" Then p(i) = 1 ElseIf list1.Text = "不等精度" Then p(i) = mj1 * mj1 / (b5(i) * b5(i)) End If l(i) = 10 ^ 4 * l2(i) / 206264.806247096 Next For i = 1 To n3 If b3(i, j) = "" Then b3(i, j) = 0 End If b(i + n2, j) = b3(i, j) If list1.Text = "等精度" Then p(i + n2) = 2350.4 * mj1 * mj1 / ((ma + mb * d1(3 * i) / 1000) * (ma + mb * d1(3 * i) / 1000)) ElseIf list1.Text = "不等精度" Then p(i + n2) = 2350.4 * mj1 * mj1 / (d4(i) * d4(i)) End If l(i + n2) = l3(i) Next Next If Form8.Caption = "附有条件的导线网" Then '如是附有条件的导线，计算系数Dim ax(), lx() ReDim ax(1 To 2 * t, 1 To n6), lx(1 To n6) For i = 1 To n6 For i1 = 1 To n1 If ax1(4 * i - 3) Like a1(3 * i1 - 2) Then x1 = a1(3 * i1 - 1): y1 = a1(3 * i1) GoTo 111 End If Next i1 = i1 - 1 For i2 = 1 To t If ax1(4 * i - 3) Like c(i2) Then x1 = x0(2 * i2 - 1): y1 = x0(2 * i2) GoTo 111 End If Next 111: For i3 = 1 To n1 If ax1(4 * i - 2) Like a1(3 * i3 - 2) Then x1 = a1(3 * i3 - 1): y1 = a1(3 * i3) GoTo 112 End If Next i3 = i3 - 1 For i4 = 1 To t If ax1(4 * i - 2) Like c(i4) Then x2 = x0(2 * i4 - 1): y2 = x0(2 * i4) GoTo 112 End If Next 112: ss1 = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)) x3 = x2 - x1: y3 = y2 - y1 If ax1(4 * i) = 0 Then '如是方位角时，计算系数lx(i) = 10000 * (xlu(x1, y1, x2, y2) - hu(ax1(4 * i - 1))) If ax1(4 * i - 3) <> a1(3 * i1 - 2) Then ax(2 * i2 - 1, i) = 10000 * y3 / (ss1 * ss1) ax(2 * i2, i) = -10000 * x3 / (ss1 * ss1) End If If ax1(4 * i - 2) <> a1(3 * i3 - 2) Then ax(2 * i4 - 1, i) = -10000 * y3 / (ss1 * ss1) ax(2 * i4, i) = 10000 * x3 / (ss1 * ss1) End If ElseIf ax1(4 * i) = 1 Then '如是距离，计算系数lx(i) = ss1 - ax1(4 * i - 1) If ax1(4 * i- 3) <> a1(3 * i1 - 2) Then ax(2 * i2 - 1, i) = -x3 / ss1: ax(2 * i2, i) = -y3 / ss1 End If If ax1(4 * i -2) <> a1(3 * i3 - 2) Then ax(2 * i4 - 1, i) = x3 / ss1: ax(2 * i4, i) = y3 / ss1 End If End If Next Fori = 1 To 2 * t For j = 1 To n6 If ax(i, j) = "" Then ax(i, j) = 0 End If Next Next End If Dim u(), nni(), xx(), nni1() ReDim u(1 To 2 * t), nni(1 To t * (2 * t + 1)) nni() = 法系数(b(), p()) u() = 常数项(b(), p(), l()) If Form8.Caption = "附有条件的导线网" Then ReDim nni1(1 To (2 * t + n6) * (2 * t + n6 + 1) / 2) nni1() = 附有条件的法方程(nni(), ax()) ReDim Preserve u(1 To 2 * t + n6) For i = 1 To n6 u(2 * t + i) = lx(i) Next nni1() = ni(nni1(), 2 * t + n6) xx() = bx(nni1(), u()) ReDim Preserve xx(1 To 2 * t) nni() = 条件从有到无(nni1(), t, n6) Else nni() = ni(nni(), 2 * t) xx() = bx(nni(), u()) End IfFor i = 1 To 2 * tx0(i) = x0(i) + xx(i)NextDim v(), fz()ReDim v(1 To n2 + n3), fz(1 To 2 * t)v() = 改正数(b(), xx(), l())Dim v1(), v2()ReDim v1(1 To n2), v2(1 To n3)For i = 1 To n2v1(i) = v(i) * 206264.806247096 / 10000m1 = m1 + v1(i) * v1(i)Nextm1 = Sqr(m1 / (n2 - 1)): m1 = Format(m1, "0.00")For i = 1 To n3v2(i) = v(i + n2)Nextmm0 = 单位权中误差(v(), p())mm0 = Sqr(mm0 / (n2 + n3 - 2 * t + n6))m0 = mm0 * 206264.806247096 / 10000If Optd2.Value Thenmj1 = m0End IfNextDim vas1 As String * 5, vas2 As String * 5, vas3 As String * 5, vas4 As String * 20Dim vas5 As String * 10, vas6 As String * 20txt = txt & Chr(13) & Chr(10)txt = txt & "导线平差成果表" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "角度观测成果表" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "-------------------------------------------------------------------" & Chr(13) & Chr(10)txt = txt & "测站" & Space(1) & "后视" & Space(1) & "前视" & Space(1) & "方向观测值(°′″)" & Space(1) & "改正数(″)" & Space(1) & "方向平差值(°′″)" & Space(1) & Chr(13) & Chr(10)Dim f(), f1(), f2()ReDim f(1 To n2)f() = 角度平差值(v1(), b1())For i = 1 To n2ReDim f1(1 To 3), f2(1 To 3)f1() = 度分离(b1(4 * i))v1(i) = Format(v1(i), "0.00")f2() = 度分离(f(i))LSet vas1 = b1(4 * i - 3)LSet vas2 = b1(4 * i - 2)LSet vas3 = b1(4 * i - 1)LSet vas4 = f1(1) & Space(1) & f1(2) & Space(1) & f1(3)LSet vas5 = v1(i)LSet vas6 = f2(1) & Space(1) & f2(2) & Space(1) & f2(3)txt = txt & vas1 & vas2 & vas3 & vas4 & vas5 & vas6 & Chr(13) & Chr(10)Nexttxt = txt & "---------------------------------------------------------------------" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "边长观测成果表" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "---------------------------------------------------------------------" & Chr(13) & Chr(10) Dim bz()ReDim bz(1 To n3 + 3)bz() = 边长相对中误差(mm0, nni(), b3(), d1())Dim bc()ReDim bc(1 To n3)bc = 边长平差值(v2(), d1())txt = txt & "起点" & Space(1) & "终点" & Space(1) & "观测边长(m)" & Space(1) & "改正数(mm)" & "边长平差值(m)" & Space(1) & "边长观测值的相对中误差" & Chr(13) & Chr(10) Dim vas7 As String * 12, vas8 As String * 12For i = 1 To n3v2(i) = v2(i) * 1000: v2(i) = Format(v2(i), "0.0")LSet vas1 = d1(3 * i - 2)LSet vas2 = d1(3 * i - 1)LSet vas7 = d1(3 * i)LSet vas5 = v2(i)LSet vas8 = bc(i)LSet vas6 = "1:" & Space(1) & bz(i)txt = txt & vas1 & vas2 & vas7 & vas5 & vas8 & vas6 & Chr(13) & Chr(10)Nexttxt = txt & "--------------------------------------------------------------------" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "点位误差及误差椭圆" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "---------------------------------------------------------------------------------" & Chr(13) & Chr(10)txt = txt & "点号" & Space(1) & "误差X(mm)" & Space(1) & "误差Y(mm)" & Space(1) & "点位误差(mm)" & Space(1) & "椭圆长轴E(mm)" & Space(1) & "椭圆短轴(mm)" & Space(1) & "方位角(°′″)" & Chr(13) & Chr(10)Dim dw(), e()ReDim dw(1 To 3 * t), e(1 To 3 * t)dw() = 点位误差(mm0, t, nni())e() = 点位误差椭圆(mm0, t, nni())Dim vas9 As String * 10, vas10 As String * 10, vas11 As String * 12, vas12 As String * 12For i = 1 To tf1() = 度分离(e(3 * i))LSet vas1 = c(i)LSet vas9 = dw(3 * i - 2)LSet vas10 = dw(3 * i - 1)LSet vas7 = dw(3 * i)LSet vas8 = e(3 * i - 2)LSet vas11 = e(3 * i - 1)LSet vas12 = f1(1) & Space(1) & f1(2) & Space(1) & f1(3)txt = txt & vas1 & vas9 & vas10 & vas7 & vas8 & vas11 & vas12 & Chr(13) & Chr(10)Nexttxt = txt & "---------------------------------------------------------------------------------" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "坐标成果表" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "----------------------------------------------" & Chr(13) & Chr(10)txt = txt & "点号" & Space(2) & "坐标X(m)" & Space(12) & "坐标Y(m)" & Space(11) & Chr(13) & Chr(10)For i = 1 To n1LSet vas1 = a1(3 * i - 2)LSet vas4 = a1(3 * i - 1)LSet vas6 = a1(3 * i)txt = txt & vas1 & vas4 & vas6 & Chr(13) & Chr(10)NextFor i = 1 To tx0(2 * i - 1) = Format(x0(2 * i - 1), "0.0000"): x0(2 * i) = Format(x0(2 * i), "0.0000")LSet vas1 = c(i)LSet vas4 = x0(2 * i - 1)LSet vas6 = x0(2 * i)txt = txt & vas1 & vas4 & vas6 & Chr(13) & Chr(10)Nextm0 = Format(m0, "0.0")txt = txt & "---------------------------------------------" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)txt = txt & "整网精度评定" & Chr(13) & Chr(10)txt = txt & Chr(13) & Chr(10)Dim vass As String * 20, vas17 As String * 20txt = txt & "----------------------------------------------" & Chr(13) & Chr(10) LSet vass = "导线全长:"LSet vas17 = bz(n3 + 3) & "Km"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "验前测角中误差:"LSet vas17 = mj & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "验后测角中误差:"LSet vas17 = m1 & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)If Form8.Caption = "附合导线" ThenLSet vass = "实测角度闭合差:"LSet vas17 = bb & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "允许角度闭合差:"LSet vas17 = bb1 & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "坐标闭合差(cm):"LSet vas17 = "fx=" & fx & Space(1) & "fy=" & fytxt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "坐标增量相对差:"LSet vas17 = "1:" & fstxt = txt & vass & vas17 & Chr(13) & Chr(10)ElseIf Form8.Caption = "闭合导线" Thenbb = Format(bb, "0.0")LSet vass = "角度闭合差:"LSet vas17 = bb & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "允许角度闭合差:"LSet vas17 = bb1 & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "坐标闭合差(cm):"LSet vas17 = "fx=" & fx & Space(1) & "fy=" & fytxt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "坐标增量相对差:"LSet vas17 = "1:" & fstxt = txt & vass & vas17 & Chr(13) & Chr(10)End IfLSet vass = "单位权中误差:"LSet vas17 = m0 & "″"txt = txt & vass & vas17 & Chr(13) & Chr(10)LSet vass = "最弱边相对中误差" & "(" & d1(3 * bz(n3 + 1) - 2) & "-" & d1(3 * bz(n3 + 1) - 1) & ")" & ":"LSet vas17 = "1:" & bz(n3 + 2)txt = txt & vass & vas17 & Chr(13) & Chr(10)Form1.Text1.Alignment = 2Form1.Text1.Text = txterrorhandler:If Err.Number = 75 ThenExit SubEnd If100: End SubPrivate Sub list1_Click()If list1.Text = "不等精度" Then '等精度和不等精度的互换Label1.Caption = "单位权中误差(″)"Text2.BackColor = &H80000004Text2.Locked = TrueText3.BackColor = &H80000004Text3.Locked = TrueElseIf list1.Text = "等精度" ThenLabel1.Caption = "测角中误差(″)"Text2.BackColor = &H80000005Text2.Locked = FalseText3.BackColor = &H80000005Text3.Locked = FalseEnd IfEnd SubPrivate Sub Opt1_Click()If Opt1.Value ThenFrame3.Enabled = FalseLabel5.Enabled = FalseText4.BackColor = &H80000004Text4.Text = 1Text4.Locked = TrueOptd1.Enabled = FalseOptd2.Enabled = FalseEnd IfEnd SubPrivate Sub Opt2_Click()If Opt2.Value ThenFrame3.Enabled = TrueLabel5.Enabled = TrueText4.BackColor = &H80000005 Text4.Locked = FalseOptd1.Enabled = TrueOptd1.Value = TrueOptd2.Enabled = TrueEnd IfEnd SubPrivate Function 查错(a1(), n1, n2)End Function[em1][em1][em1]。
四等水准测量VB 程序 代码
四等水准测量VB 程序Private Sub Command1_Click()Dim BBU As SingleDim BBM As SingleDim BBL As SingleDim BRM As SingleDim BK As SingleDim FBU As SingleDim FBM As SingleDim FBL As SingleDim FRM As SingleDim FK As SingleBBU = Val(ltrim$(rtrim$(Text1.Text) ))BBM = Val(ltrim$(rtrim$(Text2.Text) ))BBL = Val(ltrim$(rtrim$(Text3.Text) ))BRM = Val(ltrim$(rtrim$(Text4.Text) ))BK = Val(ltrim$(rtrim$(Text9.Text) ))FBU = Val(ltrim$(rtrim$(Text5.Text) ))FBM = Val(ltrim$(rtrim$(Text6.Text) ))FBL = Val(ltrim$(rtrim$(Text7.Text) ))FRM = Val(ltrim$(rtrim$(Text8.Text) ))FK = Val(ltrim$(rtrim$(Text10.Text) ))bdh = (BBM - FBM) '黑面高差'fdh = (BRM - FRM) '红面高差'If BK > FK Thenfdh = fdh - 0.1Elsefdh = fdh + 0.1End IfIf Abs((BBU - BBL) - (FBU - FBL)) * 100 > 3 Then MsgBox "前后视距较差超限"Exit Sub '退出程序'ElseIf Abs(BBM + BK - BRM) > 0.003 Then MsgBox "后视黑~红面读数较差超限"Exit Sub '退出程序'ElseIf Abs(FBM + FK - FRM) > 0.003 Then MsgBox "前视黑~红面读数较差超限"Exit Sub '退出程序'ElseIf Abs(bdh - fdh) > 0.005 ThenMsgBox "黑红面所测高差较差超限"Exit Sub '退出程序'Elsedh = Format((bdh + fdh) / 2, "0.0000") '计算高差'MsgBox "测站高差="& Str$(dh) &”m”,vbokonly,”计算结果” End IfDim hsjl As SingleDim qsjl As SingleDim qhsjc As SingleDim qhsjljc As SingleDim hchhmdsc As SingleDim qchhmdsc As SingleDim hmgc As SingleDim hmgc1 As SingleDim hhmgczc As Singlehsjl = (BBU - BBL) * 100qsjl = (FBU - FBL) * 100qhsjc = qsjl - hsjlhchhmdsc = BBU - BRMqchhmdsc = FBU - FRMhmgc = BBM - FBMhmgc1 = BRM - FRMhhmgczc = hmgc - hmgc1Text1.Text = Format(hsjl, "0.0000")Text2.Text = Format(qsjl, "0.0000")Text3.Text = Format(qhsjc, "0.0000")Text4.Text = Format(qhsjljc, "0.0000")Text5.Text = Format(hchhmdsc, "0.0000")Text6.Text = Format(qchhmdsc, "0.0000")Text7.Text = Format(hmgc, "0.0000")Text9.Text = Format(hhmgczc, "0.0000")Text8.Text = Format(hmgc1, "0.0000")End SubDim BBU As SingleDim BBM As SingleDim BBL As SingleDim BRM As SingleDim BK As SingleDim FBU As SingleDim FBM As SingleDim FBL As SingleDim FRM As SingleDim FK As SinglePrivate Sub Combo1_Click()Dim ReTxt As StringReTxt = Combo1.ListIndexBK = Combo1.List(ReTxt)End SubPrivate Sub Combo2_Click()Dim ReTxt As StringReTxt = Combo2.ListIndexFK = Combo2.List(ReTxt)End SubPrivate Sub Command1_Click()BBU = Val(LTrim$(RTrim$(Text1.Text))) BBM = Val(LTrim$(RTrim$(Text2.Text))) BBL = Val(LTrim$(RTrim$(Text3.Text))) BRM = Val(LTrim$(RTrim$(Text4.Text)))FBU = Val(LTrim$(RTrim$(Text5.Text))) FBM = Val(LTrim$(RTrim$(Text6.Text))) FBL = Val(LTrim$(RTrim$(Text7.Text))) FRM = Val(LTrim$(RTrim$(Text8.Text)))Dim BBU As SingleDim BBM As SingleDim BBL As SingleDim BRM As SingleDim BK As SingleDim FBU As SingleDim FBM As SingleDim FBL As SingleDim FRM As SingleDim FK As SinglePrivate Sub Combo1_Click()Dim ReTxt As StringReTxt = Combo1.ListIndexBK = Combo1.List(ReTxt)End SubPrivate Sub Combo2_Click()Dim ReTxt As StringReTxt = Combo2.ListIndexFK = Combo2.List(ReTxt)End SubPrivate Sub Command1_Click()BBU = Val(LTrim$(RTrim$(Text1.Text)))BBM = Val(LTrim$(RTrim$(Text2.Text)))BBL = Val(LTrim$(RTrim$(Text3.Text)))BRM = Val(LTrim$(RTrim$(Text4.Text)))FBU = Val(LTrim$(RTrim$(Text5.Text)))FBM = Val(LTrim$(RTrim$(Text6.Text)))FBL = Val(LTrim$(RTrim$(Text7.Text)))FRM = Val(LTrim$(RTrim$(Text8.Text)))bdh = (BBM - FBM) '黑面高差'fdh = (BRM - FRM) '红面高差'If BK > FK Thenfdh = fdh - 100Elsefdh = fdh + 100End IfIf Abs((BBU - BBL) - (FBU - FBL)) * 0.1 > 3 Then MsgBox "前后视距较差超限"Exit Sub '退出程序'ElseIf Abs(BBM + BK - BRM) > 3 Then MsgBox "后视黑~红面读数较差超限"Exit Sub '退出程序'ElseIf Abs(FBM + FK - FRM) > 3 Then MsgBox "前视黑~红面读数较差超限"Exit Sub '退出程序'ElseIf Abs(bdh - fdh) > 5 ThenMsgBox "黑红面所测高差较差超限"Exit Sub '退出程序'Elsedh = Format((bdh + fdh) / 2, "0.0000") '计算高差' Text10.Text = dh / 1000End IfEnd SubPrivate Sub Command2_Click()Text1.Text = ""Text2.Text = ""Text3.Text = ""Text4.Text = ""Text5.Text = ""Text6.Text = ""Text7.Text = ""Text8.Text = ""Text9.Text = ""Text10.Text = ""Text1.SetFocusEnd Sub。
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
（误差理论与测量平差础）课程设计报告系（部）：土木工程系实习单位：山东交通学院班级：测绘084学生姓名：田忠星学号080712420 带队教师：夏小裕﹑周宝兴时间：10 年12 月13日到10 年12 月19日山东交通学院目录：1.摘要P32.概述P33.水准网间接平差程序设计思路P3—P44. 平差程序流程图P4—P65. 程序源代码及说明P7—P236. 计算结果P23—P267. 总结P26—P27一：摘要在测量工作中，为了能及时发现错误和提高测量成果的精度，常作多余观测，这就产生了平差问题。
在一个平差问题中，当所选的独立参数Xˆ的个数等于必要观测数t时，可将每个观测值表达成这t个参数的函数，组成观测方程，这种以观测方程为函数模型的平差方法，就是间接平差。
二：概述：该课程设计的主要目是对水准网进行间接平差，在输入数据后依次计算高程近似值﹑误差方程和平差计算。
三：水准网间接平差程序设计思路1．根据平差问题的性质，选择t个独立量（既未知点的高程）作为参数Xˆ2. 将每一个观测量的平差值（既观测的高程差值）分别表达成3．由误差方程系数B和自由项组成法方程，法方程个数等于参数的个数t ；4. 解算法方程，求出参数Xˆ,计算参数（高程）的平差值Xˆ=X0 +xˆ；5．由误差方程计算V，求出观测量(高差)平差值6.评定精度单位权中误差VLL+ =∧VLL+ =∧平差值函数的中误差四：平差程序流程图1． 已知数据的输入需要输入的数据包括水准网中已知点数﹑未知点数以及这些点的点号，已知高程和高差观测值﹑距离观测值。
程序采用文件方式进行输入，约定文件输入的格式如下：第一行：已知点数﹑未知点数﹑观测值个数第二行：点号（已知点在前，未知点在后）第三行：已知高程（顺序与上一行的点号对应）第四行：高差观测值，按“起点点号，终点点号。
高差观测值，距离观测值”的顺序输入。
本节中使用的算例的数据格式如下2,3,71,2,3,4,55.016,6.0161,3,1.359,1.11,4,2.009,1.7 2,3,0.363,2.3,ˆ20s u n PV V r PV V T T +-==σ.ˆˆˆ0ˆϕϕϕσσQ =2,4,1.012,2.73,4,0.657,2.43,5,0.238,1.45,2,-0.595,2.62.平差计算过程（1）近似高程的计算。
用一个数组来存储高程近似值，已知点的高程放在这个数组的开头，然后按照点号输入顺序依次搜索涉及该店的高差观测值，看该高差涉及的另一点是否已知，若未知，则检查下一个高差观测值，若已知，则可以计算出当前未知点的高差近似值，并放入高程近似值数组，依次类推，直到所有未知点的高程近似值都被求出为止。
（2）列立观测值的误差方程。
根据各观测值的起止点信息及高差﹑距离值和误差方程的系数矩阵﹑权矩阵和常数项的各个元素赋值。
（3）平差计算。
通过间接平差通用过程进行平差计算，该过程将系数矩阵数组A﹑权矩阵数组P和常数向量数组L以参数的方式传入，通过计算，把平差结果存放在解向量数组X中，以参数的形式传出。
3．计算结果的输出计算的中间结果和最后结果都实时在文本框中显示，最后还可以把文本框中的内容保存在文本文件中。
4．界面设计根据以上分析，本程序采用菜单组织程序，用文本框显示数据的输入﹑计算和输出情况。
由于涉及到打开和保存文件的操作，所以还需要一个通用对话框。
（1）菜单设计。
本程序的菜单结构如表所示。
（2）窗体﹑文本框和通用对话框。
在主窗体上绘制1个文本框控件和一个通用对话框控件，并按照下图设置属性（文本框的Name属性改为txtShow）Text1设计好属性后，调整控件和窗体的大小和位置，以方便美观为好。
五：程序源代码及说明程序中涉及的公共变量及其说明如下：Dim strFileName As StringDim nn%, un%, tn%, hn% '已知点个数，未知点个数，总点数，观测值个数Dim Pname() As String '点名数组Dim Hknown() As Double '已知高程数组，存放已知点高程和高程近似值Dim be%(), en%() '观测值的起点和终点编号数组，存储的是点序号Dim h#(), s#() '高差观测值数组和距离观测值数组Dim A#(), X#(), P#(), L#() '间接平差的系数阵、解向量、权阵和常数向量1.数据输入单击“文件→打开文件”命令，弹出打开对话框，待用户选取了文件以后，程序开始读取已知数据，具体代码如下Private Sub mnuOpen_Click()Dim i As Integer '循环变量Dim strT1 As String, strT2 As StringCDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"CDg1.ShowOpen '打开对话框strFileName = CDg1.FileName '获得选中的文件名和路径Open strFileName For Input As #1 '打开文件Input #1, nn, un, hn '读入已知点个数，未知点个数，观测值个数tn = nn + unReDim 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 iFor i = 1 To nn '读入已知高程Input #1, Hknown(i)Next iFor 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 & "读入的水准网数据：" & vbCrLftxtShow.Text = txtShow.Text & " 已知点" & nn & "个，未知点" & un & "个，观测值" & hn & "个。
" & vbCrLftxtShow.Text = txtShow.Text & " 网中涉及的点名有："For i = 1 To tntxtShow.Text = txtShow.Text & Pname(i) & "，"Next itxtShow.Text = txtShow.Text & vbCrLftxtShow.Text = txtShow.Text & " 已知点高程为：" & vbCrLfFor i = 1 To nntxtShow.Text = txtShow.Text & Pname(i) & "的高程为：" & Hknown(i) & vbCrLfNext itxtShow.Text = txtShow.Text & " 各观测值分别为：" & vbCrLftxtShow.Text = txtShow.Text & "起点" & " " & "终点" & " " & "高差观测值" & " 距离观测值" & vbCrLfFor i = 1 To hntxtShow.Text = txtShow.Text & Pname(be(i)) & " " & Pname(en(i)) & " " & Format(h(i), "0.000") & " " & Format(s(i), "0.000") & vbCrLf Next iClose #1 '不要忘记关闭文件End Sub其中Order（）函数是根据点号（字符串）获得一个点的序号（数值）的自定义函数，之所以要进行这样的排序，是因为在输入和输出时需使用字符串类型的点号，而在程序计算时。
数组的下标元素需要整数型的点号。
该函数定义如下：'点名－序号转换函数Public Function Order(str As String) As IntegerDim i%For i = 1 To tnIf str = Pname(i) ThenOrder = iExit ForEnd IfNext iEnd Function2.高程近似值的计算输入数据后，点击“计算→近似高程”，程序根据已知数据计算未知点的高程近似值，并将计算的中间结果显示在文本框中，代码如下：'计算近似高程Private Sub mnuHeight_Click()Dim i%, j%For i = 1 To unFor j = 1 To hnIf be(j) = nn + i And en(j) < nn + i Then '找到一个起点相同且终点已知的观测值Hknown(nn + i) = Hknown(en(j)) - h(j)Exit ForEnd IfIf en(j) = nn + i And be(j) < nn + i Then '找到一个终点相同且起点已知的观测值Hknown(nn + i) = Hknown(be(j)) + h(j)Exit ForEnd IfNext jNext i'显示近似高程计算结果txtShow.Text = txtShow.Text & " 近似高程计算结果：" & vbCrLfFor i = 1 To untxtShow.Text = txtShow.Text & Pname(i + nn) & "：" & Format(Hknown(i + nn), "0.000") & vbCrLfNext iEnd Sub3.列立误差方程点击“计算→误差方程”命令，程序根据输入的数据给误差方程的系数矩阵﹑权矩阵和常数向量赋值，并将其结果显示在文本框中，代码如下：'列立误差方程：给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 hnIf 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 & " 列立的误差方程：" & vbCrLfFor i = 1 To hnFor j = 1 To untxtShow.Text = txtShow.Text & A(i, j) & " "Next jtxtShow.Text = txtShow.Text & " " & Format(L(i), "0.0000") & vbCrLfNext itxtShow.Text = txtShow.Text & "权矩阵：" & vbCrLfFor i = 1 To hnFor j = 1 To hntxtShow.Text = txtShow.Text & P(i, j) & " "Next jtxtShow.Text = txtShow.Text & vbCrLfNext iEnd Sub4.计算高程平差值和高程中误差和高差中误差点击“计算→平差计算”命令，程序调用间接平差通用过程求解误差方程，并求出高程平差值﹑高程中误差和高差中误差，显示在文本框中，代码如下：'平差计算Private Sub mnuAdj_Click()Dim i%, j%, VtP#(), VtPV#(), z#, AtP#(), AtPA#(), r(), Naan#(), b()Dim o() As DoubleReDim X(1 To un)ReDim o(1 To un, 1 To 1)ReDim s(1 To hn, 1 To 1)ReDim AX(1 To hn, 1 To 1)ReDim V(1 To hn, 1 To 1)ReDim VtP(1 To 1, 1 To hn)ReDim VtPV(1 To 1, 1 To 1)ReDim AtP(1 To un, 1 To hn)ReDim AtPA(1 To un, 1 To un)ReDim bAt(1 To un, 1 To hn)ReDim AbAt(1 To hn, 1 To hn)ReDim r(1 To un, 1 To un)ReDim b(1 To un, 1 To un)InAdjust A, P, L, X '调用间接平差的通用过程求解'计算并显示高程平差结果txtShow.Text = txtShow.Text & "平差计算结果：" & vbCrLftxtShow.Text = txtShow.Text & "点号初始高程(m) 高程改正数(m) 平差后高程(m)" & vbCrLfFor i = 1 To untxtShow.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") & vbCrLfNext itxtShow.Text = txtShow.Text & vbCrLf'计算改正数VFor i = 1 To unFor j = 1 To 1o(i, j) = X(i)Next jNext iMatrix_Multy AX, A, oFor i = 1 To unFor j = 1 To 1s(i, j) = L(i) * 1000Next jNext iMatrixMinus AX, s, VFor i = 1 To hnFor j = 1 To 1V(i, j) = AX(i, j) * 1000 - s(i, j)Next jNext i'计算并显示单位权中误差MatrixTrans V, VttxtShow.Text = txtShow.Text & vbCrLfMatrix_Multy VtP, Vt, PtxtShow.Text = txtShow.Text & vbCrLfMatrix_Multy VtPV, VtP, VFor i = 1 To 1For j = 1 To 1z = VtPV(i, j)Next jNext iσ0 = Sqr(z / (hn - nn))txtShow.Text = txtShow.Text & "单位权中误差：（mm）" & vbCrLf txtShow.Text = txtShow.Text & Format(σ0, "0.0000")txtShow.Text = txtShow.Text & vbCrLf'计算未知点的高程中误差MatrixTrans A, AtMatrix_Multy AtP, At, PMatrix_Multy AtPA, AtP, AFor i = 1 To unFor j = 1 To unr(i, j) = AtPA(i, j)Next jNext iCall jzqn(r(), b())txtShow.Text = txtShow.Text & "点号高程中误差：（mm）" & vbCrLf For i = 1 To unz = b(i, i)zz = σ0 * Sqr(z)txtShow.Text = txtShow.Text & Pname(nn + i) & " "txtShow.Text = txtShow.Text & " " & Format(zz, "0.0000") & vbCrLfNext i'计算高差平差值的中误差MatrixTrans A, AtMatrix_Multy bAt, b, AtMatrix_Multy AbAt, A, bAttxtShow.Text = txtShow.Text & "起点" & " " & "终点" & " " & "高差平差值的中误差（mm）" & vbCrLfFor i = 1 To hny = AbAt(i, i)yy = σ0 * Sqr(y)txtShow.Text = txtShow.Text & Pname(be(i)) & " " & Pname(en(i)) & " " & Format(yy, "0.0000") & vbCrLfNext iEnd Sub在此程序中用到了过程jzqn（）代码如下：Public Sub jzqn(Qa(), na())Dim A()n = UBound(Qa, 1)ReDim na(n, n)ReDim A(n, 2 * n)For i = 1 To nFor j = 1 To nA(i, j) = Qa(i, j)Next jNext iFor i = 1 To nFor j = n + 1 To 2 * nIf j - i = n ThenA(i, j) = 1ElseA(i, j) = 0End IfNext jNext iFor i = 1 To nIf A(i, i) = 0 ThenFor Q = i To nIf A(Q, i) <> 0 ThenFor W = i To 2 * nzj = A(i, W)A(i, W) = A(Q, W)A(Q, W) = zjNext WExit ForEnd IfNext QIf Q > n Then MsgBox "此矩阵不可逆": Exit Sub End IfFor K = 2 * n To i Step -1A(i, K) = A(i, K) / A(i, i)Next KFor j = i + 1 To nIf A(j, i) <> 0 ThenFor K = 2 * n To i Step -1A(j, K) = A(j, K) / A(j, i) - A(i, K)Next KEnd IfNext jNext iFor i = n To 1 Step -1If A(i, i) = 0 ThenFor Q = i - 1 To 1 Step -1If A(Q, i) <> 0 ThenFor W = i To 2 * nzj = A(i, W)A(i, W) = A(Q, W)A(Q, W) = zjNext WExit ForEnd IfNext QEnd IfFor K = 2 * n To i Step -1A(i, K) = A(i, K) / A(i, i)Next KFor j = i - 1 To 1 Step -1If A(j, i) <> 0 Thenxxx = A(j, i)For K = 2 * n To 1 Step -1A(j, K) = A(j, K) / xxx - A(i, K)Next KEnd IfNext jNext iFor i = 1 To nFor j = 1 To nna(i, j) = A(i, j + n)Next jNext iEnd Sub5.保存﹑退出点击“文件→保存结果”命令，将文本框中的内容保存在指定的文件中，代码如下：'保存计算结果Private Sub mnuSave_Click()CDg1.Filter = "文本文件（*.txt）|*.txt|所有文件（*.*）|*.*"CDg1.ShowSavestrFileName = CDg1.FileNameOpen strFileName For Output As #1Print #1, txtShow.TextClose #1End Sub点击“文件→退出”命令，退出程序。