四等水准计算.frm

测量水准计算程序。水准平差等。是测绘行业的一个很有用的程序

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "四等水准计算"
   ClientHeight    =   4695
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   5055
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4695
   ScaleWidth      =   5055
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox txtBMNum 
      Alignment       =   2  'Center
      Height          =   285
      Left            =   2640
      TabIndex        =   14
      Text            =   "0"
      Top             =   1440
      Width           =   855
   End
   Begin VB.TextBox txtShowResult 
      Height          =   2775
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   12
      Top             =   1800
      Width           =   4815
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "退出"
      Height          =   375
      Left            =   3600
      TabIndex        =   11
      Top             =   1320
      Width           =   1335
   End
   Begin VB.CommandButton cmdCheckCalc 
      Caption         =   "平差计算"
      Height          =   375
      Left            =   3600
      TabIndex        =   10
      Top             =   720
      Width           =   1335
   End
   Begin VB.CommandButton cmdInput 
      Caption         =   "输入观测值"
      Height          =   375
      Left            =   3600
      TabIndex        =   9
      Top             =   120
      Width           =   1335
   End
   Begin VB.Frame Frame2 
      Caption         =   "已知高程"
      Height          =   1215
      Left            =   2040
      TabIndex        =   3
      Top             =   120
      Width           =   1455
      Begin VB.TextBox txtEndPoint 
         Alignment       =   1  'Right Justify
         Height          =   285
         Left            =   600
         TabIndex        =   7
         Text            =   "208.579"
         Top             =   720
         Width           =   735
      End
      Begin VB.TextBox txtStartPoint 
         Alignment       =   1  'Right Justify
         Height          =   285
         Left            =   600
         TabIndex        =   5
         Text            =   "204.286"
         Top             =   240
         Width           =   735
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "终点"
         Height          =   195
         Left            =   120
         TabIndex        =   6
         Top             =   720
         Width           =   360
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "起点"
         Height          =   195
         Left            =   120
         TabIndex        =   4
         Top             =   240
         Width           =   360
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "路线类型："
      Height          =   1575
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   1815
      Begin VB.OptionButton optSpur 
         Caption         =   "支水准路线"
         Height          =   255
         Left            =   240
         TabIndex        =   8
         Top             =   1080
         Width           =   1455
      End
      Begin VB.OptionButton optAnnex 
         Caption         =   "附合水准路线"
         Height          =   255
         Left            =   240
         TabIndex        =   2
         Top             =   360
         Value           =   -1  'True
         Width           =   1455
      End
      Begin VB.OptionButton optClose 
         Caption         =   "闭合水准路线"
         Height          =   255
         Left            =   240
         TabIndex        =   1
         Top             =   720
         Width           =   1455
      End
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "测站数"
      Height          =   195
      Left            =   2040
      TabIndex        =   13
      Top             =   1485
      Width           =   540
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim startPoint!, endPoint!

Private Sub cmdCheckCalc_Click()
    Dim i%, tDist                '距离
    tDist = 0
    Dim totalDetH!, closeDetH!              '累计高差和高差闭合差
    
    For i = 1 To nMarks
        tDist = tDist + dis(i)
    Next i
   
    totalDetH = 0
    For i = 1 To nMarks                     '计算累计高差
        totalDetH = totalDetH + detH(i)
    Next i
    '计算闭合差
    startPoint = Val(txtStartPoint.Text)
    endPoint = Val(txtEndPoint.Text)
    If optAnnex.Value Then                  '附合水准
        closeDetH = (endPoint - startPoint) - totalDetH
    Else                                    '闭合水准和支水准
        closeDetH = -totalDetH
    End If
    '检查闭合差是否超限
    If closeDetH > 0.04 * Sqr(tDist) Then        '采用40*Sqr(L)来计算，单位是毫米
        MsgBox "闭合差超限，测量成果不合格！", , "闭合差超限"
        txtShowResult.Text = txtShowResult.Text & "闭合差超限，测量成果不合格！"
        Exit Sub
    Else
        MsgBox "闭合差合格，继续计算转点高程！", , "闭合差合格"
    End If
    
    Dim temp!
    temp = startPoint
    txtShowResult.Text = txtShowResult.Text & "平差后的高程为：" & vbCrLf
    For i = 0 To nMarks
        temp = temp + detH(i) + closeDetH * dis(i) / tDist
        txtShowResult.Text = txtShowResult.Text & "        （" & Str(i) & "）：" & Str(Format(temp, "0.000")) & vbCrLf
    Next i
End Sub

Private Sub cmdExit_Click()
    End
End Sub

Private Sub cmdInput_Click()
    '检查输入的几个文本框：是否已经输入了
    If txtStartPoint.Text = "0" Then
        MsgBox "还没有输入起始点高程！"
        Exit Sub
    End If
    If txtEndPoint.Text = "0" And optAnnex.Value = True Then
        MsgBox "还没有输入终点高程！"
        Exit Sub
    End If
    If txtBMNum.Text = "0" And optAnnex.Value = True Then
        MsgBox "还没有输入测站数！"
        Exit Sub
    End If
    
    frmInput.Show
End Sub

Private Sub optAnnex_Click()
    txtEndPoint.Enabled = optAnnex.Value
End Sub

Private Sub optClose_Click()
    txtEndPoint.Enabled = Not optClose.Value
End Sub

Private Sub optSpur_Click()
    txtEndPoint.Enabled = Not optSpur.Value
End Sub

Private Sub txtStartPoint_LostFocus()
    If Not IsNumeric(txtStartPoint.Text) Then
        MsgBox "输入的高程含有非数字字符！"
        txtStartPoint.Text = ""
        txtStartPoint.SetFocus
        Exit Sub
    End If
    If Val(txtStartPoint.Text) > 5000 Or Val(txtStartPoint.Text) < -100 Then
        MsgBox "输入的高程有误！"
        txtStartPoint.Text = ""
        txtStartPoint.SetFocus
        Exit Sub
    End If
    startPoint = Val(txtStartPoint.Text)
End Sub

Private Sub txtEndPoint_LostFocus()
    If Not IsNumeric(txtEndPoint.Text) Then
        MsgBox "输入的高程含有非数字字符！"
        txtEndPoint.Text = ""
        txtEndPoint.SetFocus
        Exit Sub
    End If
    If Val(txtEndPoint.Text) > 5000 Or Val(txtEndPoint.Text) < -100 Then
        MsgBox "输入的高程有误！"
        txtEndPoint.Text = ""
        txtEndPoint.SetFocus
        Exit Sub
    End If
    endPoint = Val(txtEndPoint.Text)
End Sub

Private Sub txtBMNum_LostFocus()
    If Not IsNumeric(txtBMNum.Text) Then
        MsgBox "输入的测站数含有非数字字符或尚未输入！"
        txtBMNum.Text = ""
        txtBMNum.SetFocus
        Exit Sub
    End If
    nMarks = Val(txtBMNum.Text)
    If txtBMNum.Text <> "" And (nMarks > 20 Or nMarks < 2) Then
        MsgBox "输入的测站数有误！"
        txtBMNum.Text = ""
        txtBMNum.SetFocus
        Exit Sub
    End If
    ReDim dis(nMarks) As Single, detH(nMarks) As Single
End Sub