大地四边形的计算.frm

在测量平差中

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form Form1 
   Caption         =   "大地四边形的计算"
   ClientHeight    =   4695
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   5505
   LinkTopic       =   "Form1"
   ScaleHeight     =   4695
   ScaleWidth      =   5505
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdAdjust 
      Caption         =   "条件平差"
      Height          =   1215
      Left            =   5040
      TabIndex        =   26
      Top             =   240
      Width           =   375
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "退出"
      Height          =   1215
      Left            =   5040
      TabIndex        =   25
      Top             =   3360
      Width           =   375
   End
   Begin VB.CommandButton cmdClear 
      Caption         =   "清空"
      Height          =   1215
      Left            =   5040
      TabIndex        =   24
      Top             =   1800
      Width           =   375
   End
   Begin VB.Frame Frame2 
      Caption         =   "计算结果"
      Height          =   4455
      Left            =   2640
      TabIndex        =   12
      Top             =   120
      Width           =   2295
      Begin VB.TextBox txtXc 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   17
         Text            =   "0"
         Top             =   360
         Width           =   1095
      End
      Begin VB.TextBox txtYc 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   16
         Text            =   "0"
         Top             =   720
         Width           =   1095
      End
      Begin VB.TextBox txtXd 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   14
         Text            =   "0"
         Top             =   1200
         Width           =   1095
      End
      Begin VB.TextBox txtYd 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   13
         Text            =   "0"
         Top             =   1560
         Width           =   1095
      End
      Begin MSFlexGridLib.MSFlexGrid MSFlexGrid2 
         Height          =   2295
         Left            =   120
         TabIndex        =   15
         Top             =   2040
         Width           =   2055
         _ExtentX        =   3625
         _ExtentY        =   4048
         _Version        =   393216
         Rows            =   9
      End
      Begin VB.Label Label12 
         AutoSize        =   -1  'True
         Caption         =   "X坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   23
         Top             =   360
         Width           =   450
      End
      Begin VB.Label Label11 
         AutoSize        =   -1  'True
         Caption         =   "Y坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   22
         Top             =   720
         Width           =   450
      End
      Begin VB.Label Label10 
         AutoSize        =   -1  'True
         Caption         =   "C点："
         Height          =   180
         Left            =   120
         TabIndex        =   21
         Top             =   480
         Width           =   450
      End
      Begin VB.Label Label9 
         AutoSize        =   -1  'True
         Caption         =   "X坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   20
         Top             =   1200
         Width           =   450
      End
      Begin VB.Label Label8 
         AutoSize        =   -1  'True
         Caption         =   "Y坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   19
         Top             =   1560
         Width           =   450
      End
      Begin VB.Label Label7 
         AutoSize        =   -1  'True
         Caption         =   "D点："
         Height          =   180
         Left            =   120
         TabIndex        =   18
         Top             =   1320
         Width           =   450
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "已知数据"
      Height          =   4455
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   2295
      Begin VB.TextBox txtYb 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   10
         Text            =   "570006.65"
         Top             =   1560
         Width           =   1095
      End
      Begin VB.TextBox txtXb 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   8
         Text            =   "108451.06"
         Top             =   1200
         Width           =   1095
      End
      Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1 
         Height          =   2295
         Left            =   120
         TabIndex        =   5
         Top             =   2040
         Width           =   2055
         _ExtentX        =   3625
         _ExtentY        =   4048
         _Version        =   393216
         Rows            =   9
      End
      Begin VB.TextBox txtYa 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   4
         Text            =   "570286.23"
         Top             =   720
         Width           =   1095
      End
      Begin VB.TextBox txtXa 
         Alignment       =   1  'Right Justify
         Height          =   270
         Left            =   1080
         TabIndex        =   2
         Text            =   "107248.61"
         Top             =   360
         Width           =   1095
      End
      Begin VB.Label Label6 
         AutoSize        =   -1  'True
         Caption         =   "B点："
         Height          =   180
         Left            =   120
         TabIndex        =   11
         Top             =   1320
         Width           =   450
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         Caption         =   "Y坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   9
         Top             =   1560
         Width           =   450
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         Caption         =   "X坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   7
         Top             =   1200
         Width           =   450
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "A点："
         Height          =   180
         Left            =   120
         TabIndex        =   6
         Top             =   480
         Width           =   450
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         Caption         =   "Y坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   3
         Top             =   720
         Width           =   450
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "X坐标"
         Height          =   180
         Left            =   600
         TabIndex        =   1
         Top             =   360
         Width           =   450
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

    Const PI = 3.141592653589
    Dim Xa#, Ya#, Xb#, Yb#, Xc#, Yc#, Xd#, Yd#      '坐标
    Dim angle(1 To 8) As Double, V(1 To 8) As Double  '角度和改正数
    Dim i%, j%                                      '循环变量
    
'输入已知数据
Private Sub GetData()
    Xa = Val(txtXa.Text): Ya = Val(txtYa.Text)
    Xb = Val(txtXb.Text): Yb = Val(txtYb.Text)
    With MSFlexGrid1
        .Col = 1
        For i = 1 To 8
            .Row = i
            angle(i) = Val(.Text)
        Next i
    End With
    
    '计算
    For i = 1 To 8              '度.分秒形式化为弧度
        angle(i) = DoToHu(angle(i))
    Next i
End Sub


'严密平差
Private Sub cmdAdjust_Click()
    Dim W(1 To 4) As Double, B(1 To 4, 1 To 8) As Double, P(1 To 8, 1 To 8) As Double
    
    '输入数据
    Call GetData
    
    '给系数矩阵B赋值
    B(1, 1) = 1: B(1, 2) = 1: B(1, 3) = 1: B(1, 4) = 1
    B(2, 1) = 1: B(2, 2) = 1: B(2, 7) = 1: B(2, 8) = 1
    B(3, 1) = 1: B(3, 2) = 1: B(3, 3) = 1: B(3, 4) = 1
    B(3, 5) = 1: B(3, 6) = 1: B(3, 7) = 1: B(3, 8) = 1
    B(4, 1) = 1 / Tan(angle(1) + angle(8)) - 1 / Tan(angle(1))
    B(4, 4) = 1 / Tan(angle(4)) - 1 / Tan(angle(4) + angle(5))
    B(4, 5) = -1 / Tan(angle(4) + angle(5))
    B(4, 6) = 1 / Tan(angle(6))
    B(4, 7) = -1 / Tan(angle(7))
    B(4, 8) = 1 / Tan(angle(1) + angle(8))
    '计算闭合差
    W(1) = angle(1) + angle(2) + angle(3) + angle(4) - PI
    W(2) = angle(1) + angle(2) + angle(7) + angle(8) - PI
    W(3) = angle(1) + angle(2) + angle(3) + angle(4) + angle(5) + angle(6) + angle(7) + angle(8) - 2 * PI
    W(4) = 206265 * (1 - Sin(angle(1)) / Sin(angle(4)) * Sin(angle(7)) / Sin(angle(1) + angle(8)) / Sin(angle(6)) * Sin(angle(4) + angle(5)))
    W(4) = W(4) / 1000000
    '组成权矩阵
    P(1, 1) = 1: P(2, 2) = 1: P(3, 3) = 1: P(4, 4) = 1
    P(5, 5) = 1: P(6, 6) = 1: P(7, 7) = 1: P(8, 8) = 1
    
    '条件平差
    CondiAdjust B, P, W, V
    
    '求结果并显示
    Call GetResult
End Sub

'求结果并显示
Private Sub GetResult()
    For i = 1 To 8              '计算改正后的角度值
        angle(i) = angle(i) - V(i)
    Next i
    '调用前方交会计算过程计算待定点坐标
    Call FrontCalc(Xa, Ya, Xb, Yb, angle(2) + angle(3), angle(1), Xc, Yc)
    Call FrontCalc(Xa, Ya, Xb, Yb, angle(2), angle(1) + angle(8), Xd, Yd)
    
    '数据的输出
    txtXc.Text = Format(Xc, "0.000"): txtYc.Text = Format(Yc, "0.000")
    txtXd.Text = Format(Xd, "0.000"): txtYd.Text = Format(Yd, "0.000")
    With MSFlexGrid2
        .Col = 1
        For i = 1 To 8
            .Row = i
            .Text = Str(HuToDo(angle(i)))
        Next i
    End With
End Sub

Private Sub cmdClear_Click()
    txtXa.Text = "": txtYa.Text = ""
    txtXb.Text = "": txtYb.Text = ""
    txtXc.Text = "": txtYc.Text = ""
    txtXd.Text = "": txtYd.Text = ""
    txtXa.SetFocus
End Sub

Private Sub cmdExit_Click()
    End
End Sub

Private Sub Form_Load()
    Dim i%
    With MSFlexGrid1
        .MousePointer = flexIBeam
        .Col = 0: .Row = 0
        .Text = "观测值"
        .Col = 1: .Row = 0
        .Text = "角度"
        .Col = 0
        For i = 1 To 8
            .Row = i
            .Text = "角" & Str(i)
        Next i
        .Col = 1
        .Row = 1: .Text = 53.0915
        .Row = 2: .Text = 33.3554
        .Row = 3: .Text = 30.0455
        .Row = 4: .Text = 63.0959
        .Row = 5: .Text = 62.5106
        .Row = 6: .Text = 23.5406
        .Row = 7: .Text = 30.013
        .Row = 8: .Text = 63.1312
    End With
    With MSFlexGrid2
        .MousePointer = flexIBeam
        .Col = 0: .Row = 0
        .Text = "平差值"
        .Col = 1: .Row = 0
        .Text = "角度"
        .Col = 0
        For i = 1 To 8
            .Row = i
            .Text = "角" & Str(i)
        Next i
    End With
End Sub

Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer)
    Dim c As String
    c = Chr(KeyAscii)
    With MSFlexGrid1
        If IsNumeric(c) Or c = "." Then
            .Text = .Text & c
        ElseIf KeyAscii = 8 Then
            If Len(.Text) > 0 Then .Text = Left(.Text, Len(.Text) - 1)
        End If
    End With
End Sub

Private Sub MSFlexGrid1_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 46 Then
        MSFlexGrid1.Text = ""
    End If
End Sub

Private Sub MSFlexGrid2_KeyPress(KeyAscii As Integer)
    With MSFlexGrid2
        If IsNumeric(Chr(KeyAscii)) Then
            .Text = .Text & Chr(KeyAscii)
        ElseIf KeyAscii = 8 Then
            If Len(.Text) > 0 Then .Text = Left(.Text, Len(.Text) - 1)
        End If
    End With
End Sub

Private Sub MSFlexGrid2_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 46 Then
        MSFlexGrid2.Text = ""
    End If
End Sub

'弧度化为度.分秒的形式：输入弧度值，输出度.分秒（各占两位）
Public Function HuToDo(ByVal Hu As Double) As Single
    Dim du%, fen%, miao%
    
    Hu = Hu * 180 / PI
    
    du = Fix(Hu)
    Hu = (Hu - du) * 60
    fen = Fix(Hu)
    Hu = (Hu - fen) * 60
    miao = Fix(Hu + 0.5)
    If miao = 60 Then
        fen = fen + 1
        miao = 0
    End If
    
    HuToDo = du + fen / 100 + miao / 10000
End Function


'将度.分秒形式化为弧度：输入为度.分秒形式，输出为弧度
Public Function DoToHu(ByVal DoFenMiao As Double) As Single
    Dim du%, fen%, miao%, angle#
    
    du = Fix(DoFenMiao)
    DoFenMiao = (DoFenMiao - du) * 100
    fen = Fix(DoFenMiao)
    miao = (DoFenMiao - fen) * 100
    
    angle = du + fen / 60 + miao / 3600
    DoToHu = angle * PI / 180
End Function


'计算前方交会点：由A、B两点坐标和角度a、b计算待测点P的坐标
Public Sub FrontCalc(Xa#, Ya#, Xb#, Yb#, A#, B#, Xp#, Yp#)
    Dim ctga#, ctgb#
    ctga = 1 / Tan(A)
    ctgb = 1 / Tan(B)
    Xp = (Xa * ctgb + Xb * ctga + (Yb - Ya)) / (ctga + ctgb)
    Yp = (Ya * ctgb + Yb * ctga + (Xa - Xb)) / (ctga + ctgb)
End Sub