平面控制网间接平差.frm

测量间接平差vb源代码,测量工作者的福音

            FoundDir2 = True
            Exit Function
        End If
    Next k
End Function

'输入观测数据
Private Sub mnuInput_Click()
    Screen.MousePointer = 13
    
    CDg1.Filter = "Text Files(*.TXT)|*.txt"
    CDg1.Action = 1
    
    strFileName = CDg1.FileName
    If strFileName = "" Then Exit Sub
    
    Dim i%, j%                              '循环变量
    Dim strT1$, strT2$, strT3$              '临时字符串
    Dim Err1%, Err2%, Err3%, Err4%          '错误号，分别表示找不到起点、终点编号和起末点相同的错误
    
    txtShow.Text = txtShow.Text & "    数据文件:" & vbCrLf
    Open strFileName For Input As #1
        Input #1, Net                       '读入网形参数
        txtShow.Text = txtShow.Text & "Net = " & Str(Net) & vbCrLf
        Input #1, nn, un                    '读入点数
        tn = nn + un
        ReDim Pname(tn), X0(tn), Y0(tn), X(tn), Y(tn)     '声明点名、初始坐标数组和坐标平差值大小
        txtShow.Text = txtShow.Text & "已知点" & Str(nn) & "个，未知点" & Str(un) & "个" & vbCrLf
        For i = 1 To tn                     '读入各点名
            Input #1, Pname(i)
            txtShow.Text = txtShow.Text & "Pname(" & i & ")=" & Pname(i) & " , "
        Next i
        txtShow.Text = txtShow.Text & vbCrLf
        For i = 1 To nn                     '读入已知点坐标
            Input #1, X0(i), Y0(i)
            '去掉带号和500公里
            N500 = Val(Left(Trim(Str(Y0(i))), 2))      '得到带号
            N500 = N500 * 10 + 5
            Y0(i) = Y0(i) - N500 * 100000        '给Y坐标去掉带号和500Km
            txtShow.Text = txtShow.Text & "x0(" & i & ")=" & Str(X0(i)) & " , " & "y0(" & i & ")=" & Str(Y0(i)) & vbCrLf
        Next i
        Input #1, Ne, Nd                    '读入边长、角度观测值、方位角观测值的个数
        txtShow.Text = txtShow.Text & "边长观测值" & Str(Ne) & "个,角度观测值" & Str(Nd) & "个。" & vbCrLf
        
        If Ne > 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
                        Print #1, "点号相同的计算路线"
                        Print #1, "aa(" & i & ")", "bb(" & i & ")", "cc(" & i & ")"
                    Close #1
                End If
                If Err1 + Err2 + Err3 + Err4 <> 0 Then MsgBox "计算路线有误", 1, "错误"
            Next i
        End If
    Close #1
    
    Screen.MousePointer = 0
End Sub

'计算点位误差椭圆
Private Sub mnuPointElli_Click()
    Screen.MousePointer = 13
    
    Dim i%, ii%                             '循环变量，辅助记数
    Dim Q1#, Q2#, Q3#, T1#, T2#, T3#, tt#   '临时变量
    Dim Mx#, My#, m#                       'x、y坐标的误差以及总的点位误差
    Dim Fai#, Fa#, Fb#                      '误差椭圆的偏心率、长轴、短轴
    
    Open App.Path & "\点位误差椭圆.txt" For Output As #1
        Print #1, "    点位误差椭圆："
        For i = 1 To un
            
            Q1 = Q(2 * i - 1, 2 * i - 1):   Q2 = Q(2 * i, 2 * i):   Q3 = Q(2 * i - 1, 2 * i)
            T1 = Q1 - Q2:                   T2 = 2 * Q3:            T3 = Q1 + Q2
            Mx = Sqr(Q1):                   My = Sqr(Q2):           m = Sqr(T3)
            
            '求Fai：这里是角度值
            If Abs(T1) < 1E-16 Then
                If Q3 >= 0 Then Fai = 90 Else Fai = -90
            Else
                Fai = Atn(T2 / T1) * 57.2958
            End If
            If T1 >= 0 And T2 >= 0 Then
                Fai = Fai / 2
            Else
                If T1 >= 0 And T2 <= 0 Then Fai = (Fai + 360) / 2 Else Fai = (Fai + 180) / 2
            End If
            
            '求长、短轴
            tt = Sqr(T1 ^ 2 + T2 ^ 2):      Fa = Sqr((T3 + tt) / 2): Fb = Sqr((T3 - tt) / 2)
            
            Mx = uW0 * Mx:             My = uW0 * My:               m = uW0 * m
            Fa = uW0 * Fa:             Fb = uW0 * Fb
            
            Print #1, Pname(i + nn), "Mx=" & Format(Mx, "0.0000"), "My=" & Format(My, "0.0000"), "M=" & Format(m, "0.0000"),
            Print #1, "a=" & Format(Fa, "0.0000"), "b=" & Format(Fb, "0.0000"), "φ=" & Format(Fai, "0.00000")
        Next i
    Close #1
    
    '把误差椭圆的计算内容显示在窗体上
    txtShow.Text = txtShow.Text & vbCrLf
    Open App.Path & "\点位误差椭圆.txt" For Input As #1
        Dim strT As String
        Do While Not EOF(1)
            Line Input #1, strT
            txtShow.Text = txtShow.Text & strT & vbCrLf
        Loop
    Close #1
    
    Screen.MousePointer = 0
End Sub

'程序退出时检查是否已保存结果
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 If
End 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 Sub