平面和高程控制测量VB程序设计报告

题目：习题7.1平面和高程控制网平差蒲浡轩测绘C101班106684余数7一、 设计思路题目为：平面控制网和高程控制网的平差1、 流程图2、界面设计 上面为开始主程序，在该页面进行高程控制网平差，点击平面控制启动下面的程序页面进行平面控制网平差。2、 功能设计通过菜单实现程序的各个功能，通过菜单启动Common Dialog Control控件输入txt文档，读取txt里面的高程或平面控制网数据，然后点击各个计算菜单进行平差计算二、算法及代码实现1、Form1代码：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#() 间接平差的系数阵、解向量、权阵和常数向量高程平差计算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 iEnd SubPrivate Sub mnuCalc_Click(Index As Integer)Form1.Visible = FalsefrmMain.Visible = TrueEnd Sub误差方程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 iEnd SubPrivate 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 iEnd Sub打开高程文件Private Sub mnuHOpen_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 iEnd Function程序退出时检查是否已保存结果Private Sub Form_Unload(Cancel As Integer) If txtShow.Text Then Dim iMsg% iMsg = MsgBox(是否保存计算结果？, vbYesNoCancel, 注意保存！) If iMsg = vbYes Then mnuSave_Click If iMsg = vbCancel Then Cancel = True End IfEnd Sub保存计算结果Private Sub mnuSave_Click() Dim iMsg%reSave: CDg1.FileName = : CDg1.Filter = Text Files(*.TXT)|*.txt CDg1.Action = 2 strFileName = CDg1.FileName If strFileName = Then iMsg = MsgBox(请选择文件名！, vbYesNoCancel, 注意！) If iMsg = vbYes Then GoTo reSave: Else txtShow.Text = Exit Sub End If End If Open strFileName For Output As #1 Print #1, txtShow.Text Close #1 txtShow.Text = End Sub3、 frmMain代码： Option Explicit Const PI = 3.14159265358979 Const RU = 206264.8 Dim Net%, nn%, un%, tn% 网的类型，已知点个数，未知点个数，总点数 Dim Pname() As String 点名数组，大小为tn Dim X0#(), Y0#() 已知点坐标及未知点近似坐标，大小为tn Dim x#(), Y#() 已知点坐标及未知点平差坐标，大小为tn Dim N500% 记录Y坐标的带号，读入数据时减该常数，输出数据时加 Dim Ne%, Nd% 边长观测值个数，方向观测值个数 Dim mM#, pP# 边长观测值的固定误差和比例误差，单位为mm和ppm Dim bE%(), eE%(), s#() 边长观测值的起点、终点、边长 Dim mD#, Dir0#(), Dir#() 方向中误差，原始方向数组和排序后的方向数组 Dim bD0%(), eD0%(), bD%(), eD%() 方向起终点原始数组和排序后的数组 Dim Si%(), Ni%() 统计总的方向数和每个测站的方向数 Dim aa%(), bb%(), cc%() 近似坐标的计算路线，个数与未知点个数相同 Dim Pa#(700, 9), Pa3#(200, 40), W#(400) 误差方程系数（压缩方式存放）和常数向量 Dim qL#(700), qLS#(200) 误差方程权和虚拟误差方程的权 Dim Q(100, 100) As Double 协方差阵，Q=N(-1) Dim uW0# 单位权中误差 Dim strFileName As String检查数据并将点名转换为序号第一个参数是要检查的点名，第二个参数是得到的序号；返回值是错误号Public Function ChkData(strP As String, Order%) As Integer Dim i%, bFound As Boolean Order = 0 bFound = False For i = 1 To tn If strP = Pname(i) Then bFound = True Order = i ChkData = 0 Exit For End If Next i If Not bFound Then Open App.Path & err.log For Output As #1 Print #1, 未找到的点号： & strP & vbCrLf Close #1 ChkData = 1 MsgBox 有未找到的点号, 1, 输入错误 End IfEnd Function文本框大小随窗口大小的改变而改变Private Sub Form_Resize() txtShow.Width = frmMain.Width - 330 If frmMain.Height 1030 Then txtShow.Height = frmMain.Height - 1030 txtShow.Left = 120 txtShow.Top = 120End Sub退出程序Private Sub mnuExit_Click() EndEnd Sub计算近似坐标Private Sub mnuCalcCoor_Click() Screen.MousePointer = 13 Dim i%, j%, k% 循环变量 If Net = 1 Then 按边长计算近似坐标：使用前方交会方法 Dim Sa#, Sb#, Sc#, al#, bl#, cl# 三角形边长和三个内角 For i = 1 To un Sc = DistAB(X0(aa(i), Y0(aa(i), X0(bb(i), Y0(bb(i) For j = 1 To Ne If (bE(j) = bb(i) And eE(j) = cc(i) Or (bE(j) = cc(i) And eE(j) = bb(i) Then Sa = s(j) If (bE(j) = aa(i) And eE(j) = cc(i) Or (bE(j) = cc(i) And eE(j) = aa(i) Then Sb = s(j) Next j Call GetInnerAngleS(Sa, Sb, Sc, al, bl, cl) 求三角形三个内角 调用前方交会程序计算待定点坐标 ForIntersec X0(aa(i), Y0(aa(i), X0(bb(i), Y0(bb(i), al, bl, X0(cc(i), Y0(cc(i) Next i 显示计算结果 Open App.Path & 按边长计算近似坐标.txt For Output As #1 Print #1, 按边长计算近似坐标： txtShow.Text = txtShow.Text & 按边长计算近似坐标： & vbCrLf For i = nn + 1 To tn Print #1, Pname(i), Format(X0(i), 0.0000), Format(Y0(i), 0.0000) txtShow.Text = txtShow.Text & Pname(i) & , & Format(X0(i), 0.0000) & , & Format(Y0(i), 0.0000) & vbCrLf Next i Close #1 End If If Net = 2 Then 根据方向观测值计算近似坐标：使用前方交会方法 Dim Ta#, Tb# 用于交会的两个角 For i = 1 To un Ta = GetBeta(bb(i), aa(i), cc(i), j) 求角A Tb = GetBeta(aa(i), bb(i), cc(i), j) 求角B 调用前方交会程序计算待定点坐标 ForIntersec X0(aa(i), Y0(aa(i), X0(bb(i), Y0(bb(i), Ta, Tb, X0(cc(i), Y0(cc(i) Next i Open App.Path & 按方向计算近似坐标.txt For Output As #1 Print #1, 按方向计算近似坐标： txtShow.Text = txtShow.Text & 按方向计算近似坐标： & vbCrLf For i = nn + 1 To tn Print #1, Pname(i), Format(X0(i), 0.0000), Format(Y0(i), 0.0000) txtShow.Text = txtShow.Text & Pname(i) & , & Format(X0(i), 0.0000) & , & Format(Y0(i), 0.0000) & vbCrLf Next i Close #1 End If If Net 2 Then 根据边角条件计算近似坐标：使用极坐标方法 Dim dblS#, dblA#, dblD# 极坐标方法中的边长、夹角、方位角 Dim dir1#, dir2#, bF As Boolean 两个临时的方向，一个逻辑开关 For i = nn + 1 To tn For j = Si(i) To Si(i) + Ni(i) - 1 If eD(j) i Then 如果搜索要用到的边长和方向值，则根据极坐标法计算待丁点坐标 If FoundSid(eD(j), i, dblS) And FoundDir1(eD(j), i, dir1) Then bF = False For k = Si(eD(j) To Si(eD(j) + Ni(eD(j) - 1 If eD(k) i Then dir2 = Dir(k): bF = True dblA = dir1 - dir2: If dblA 0 Then dblA = dblA + 2 * PI 调用极坐标方法求点的坐标 PolarPositioning X0(eD(k), Y0(eD(k), X0(eD(j), Y0(eD(j), dblS, dblA, X0(i), Y0(i) Exit For End If Next k If bF Then Exit For End If End If Next j Next i txtShow.Text = txtShow.Text & 按全边角网计算近似坐标(m): & vbCrLf Open App.Path & 按全边角网计算近似坐标.txt For Output As #1 Print #1, 按全边角网计算近似坐标(m)： For i = nn + 1 To tn Print #1, Pname(i), Format(X0(i), 0.0000), Format(Y0(i), 0.0000) txtShow.Text = txtShow.Text & str(Pname(i) & & Format(X0(i), 0.0000) & , & Format(Y0(i), 0.0000) & vbCrLf Next i Close #1 End If Screen.MousePointer = 0End Sub搜索已知起点和终点的边Public Function FoundSid(beNode%, enNode%, dblS#) As Boolean Dim k% 循环变量 FoundSid = False For k = 1 To Ne If (bE(k) = beNode And eE(k) = enNode) Or (bE(k) = enNode And eE(k) = beNode) Then dblS = s(k) FoundSid = True Exit Function End If Next kEnd Function搜索已知起点和终点的起始方向值Public Function FoundDir1(beNode%, enNode%, dblDir#) As Boolean Dim k% 循环变量 FoundDir1 = False For k = Si(beNode) To Si(beNode) + Ni(beNode) - 1 If eD(k) = enNode Then dblDir = Dir(k) FoundDir1 = True Exit Function End If Next kEnd Function搜索已知起点和终点的终止方向值Public Function FoundDir2(beNode%, enNode%, dblDir#) As Boolean Dim k% 循环变量 FoundDir2 = False For k = Si(beNode) To Si(beNode) + Ni(beNode) - 1 If eD(k) 0 Then 如果有边长观测值，那么读入边长观测值 Input #1, mM, pP 输入边长精度：固定误差和比例误差 txtShow.Text = txtShow.Text & 边长固定误差 & Format(mM, 0.00) & mm,比例误差 & str(pP) & ppm。 & vbCrLf ReDim bE(Ne), eE(Ne), s(Ne) 声明边数组大小 For i = 1 To Ne 输入边长有关信息 Input #1, strT1, strT2, s(i) Err1 = ChkData(strT1, bE(i) 检查起点并计算起点序号 Err2 = ChkData(strT2, eE(i) 检查终点并计算终点序号 txtShow = txtShow & be( & i & )= & Pname(bE(i) & , & eE( & i & )= & Pname(eE(i) & , & s( & i & )= & str(s(i) & , & vbCrLf Next i 读入的边长数据写入文件，并做检查 Open App.Path & 边长观测值数据.txt For Output As #2 Print #2, 边长观测值： Print #2, mm= & mM Print #2, pp= & pP For i = 1 To Ne Print #2, bE( & i & )=; Pname(bE(i); , eE( & i & )=; Pname(eE(i); , s( & i & )=; s(i) Next i Close #2 检查边的起点与终点是否相同 Err3 = 0 For i = 1 To Ne If bE(i) = eE(i) Then Err3 = 1 Open App.Path & err.log For Output As #2 Print #2, s( & i & ), bE( & i & )= & Pname(bE(i), eE( & i & )= & Pname(eE(i) Close #2 End If Next i If Err1 + Err2 + Err3 0 Then MsgBox 边长输入错误, 1, 出错 End If If Nd 0 Then 如果有方向观测值，那么读入方向观测值 Dim ii%, ik% 辅助循环变量 Input #1, mD 读入方向中误差 txtShow.Text = txtShow.Text & 方向中误差： & str(mD) & vbCrLf ReDim bD(1 To Nd), eD(1 To Nd), Dir(Nd) 声明方向数组大小 ReDim Si(Nd), Ni(Nd) 声明测站测回数数组的大小 ReDim bD0(Nd), eD0(Nd), Dir0(Nd) 声明辅助方向数组大小 For i = 1 To Nd Input #1, strT1, strT2, Dir(i) Err1 = ChkData(strT1, bD(i) 检查起点并计算起点序号 Err2 = ChkData(strT2, eD(i) 检查终点并计算终点序号 txtShow = txtShow & bD( & i & )= & Pname(bD(i) & ； eD( & i & )= & Pname(eD(i) & ； dir( & i & )= & Dir(i) & vbCrLf Next i 读入的方向数据写入文件并检查 Open App.Path & 方向观测值数据.txt For Output As #2 Print #2, 方向观测值中误差md= & mD For i = 1 To Nd bD0(i) = bD(i): eD0(i) = eD(i): Dir0(i) = Dir(i): Dir(i) = DoToHu(Dir(i) Next i Err3 = 0 For i = 1 To Nd If bD0(i) = eD0(i) Then Err3 = 1 Open App.Path & err.log For Output As #3 Print #3, dir( & i & ), bD( & i & )= & Pname(bD0(i), eD( & i & )= & Pname(eD0(i) Close #3 End If Next i If Err1 + Err2 + Err3 0 Then MsgBox 方向输入错误, 1, 输入出错 统计每个测站的方向数 ik = 1: Si(1) = 1 For i = 1 To tn ii = 0 For j = 1 To Nd If bD0(j) = i Then ii = ii + 1 bD(ik) = bD0(j) eD(ik) = eD0(j) Dir(ik) = DoToHu(Dir0(j) ik = ik + 1 End If Next j Ni(i) = ii Si(i + 1) = Si(i) + Ni(i) Next i For i = 1 To Nd Print #2, bD( & i & )= & bD(i) Print #2, eD( & i & )= & eD(i) Print #2, dir( & i & )= & Format(Dir0(i), 0.00000) Print #2, dir( & i & )= & Format(DoToHu(Dir0(i), 0.00000) Next i Close #2 End If If Net = 1 Or Net = 2 Then 读取近似坐标的计算路线 For i = 1 To un Input #1, aa(i), bb(i), cc(i) Err1 = ChkData(strT1, aa(i) 检查起点并计算起点序号 Err2 = ChkData(strT2, bb(i) 检查中点并计算终点序号 Err3 = ChkData(strT3, cc(i) 检查终点并计算终点序号 Next i Open App.Path & 近似坐标计算路线.txt For Output As #2 Print #1, 近似坐标计算路线： For i = 1 To un Print #1, aa(i), bb(i), cc(i) Next i Close #1 For i = 1 To un Err4 = 0 If aa(i) = bb(i) Or bb(i) = cc(i) Or cc(i) = aa(i) Then Err4 = 1 Open App.Path & err.log For Output As #1