水准网间接平差.frm

采用VB编写

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmLevelNet 
   Caption         =   "水准网间接平差"
   ClientHeight    =   3735
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   7695
   LinkTopic       =   "Form1"
   ScaleHeight     =   3735
   ScaleWidth      =   7695
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog CDg1 
      Left            =   2640
      Top             =   1680
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.TextBox txtShow 
      Height          =   3735
      Left            =   0
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   0
      Width           =   7695
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&File)"
      Begin VB.Menu mnuOpen 
         Caption         =   "打开数据"
      End
      Begin VB.Menu mnuSave 
         Caption         =   "保存结果"
      End
      Begin VB.Menu aa 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "退出"
         Shortcut        =   ^E
      End
   End
   Begin VB.Menu mnuCalc 
      Caption         =   "计算(&Calc)"
      Begin VB.Menu mnuHeight 
         Caption         =   "近似高程"
      End
      Begin VB.Menu mnuEqu 
         Caption         =   "误差方程"
      End
      Begin VB.Menu mnuAdj 
         Caption         =   "平差计算"
      End
   End
End
Attribute VB_Name = "frmLevelNet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

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