formbaselz.frm

用VB编写的水准平差软件

sin_2o1r0 = sin_2o1 * Cos((2 * o0)) + cos_2o1 * Sin((2 * o0))
cos_2o1r0 = cos_2o1 * Cos(2 * o0) - sin_2o1 * Sin(2 * o0)
o = o0 + (BB + 5 * CC * cos_2o1r0) * sin_2o1r0 / (AA + 1E-16)

oo = (aaa * o + bbb * (sin_2o1r0 - sin_2o1)) * sin_A0

sin_u2 = sin_u1 * Cos(o) + cos_u1 * Cos(A12) * Sin(o)
B2 = Atn(sin_u2 / (Sqr(1 - ee) * Sqr(1 - sin_u2 * sin_u2)))
yy = Atn(Sin(A12) * Sin(o) / (cos_u1 * Cos(o) - sin_u1 * Sin(o) * Cos(A12)))
If (Sin(A12) >= 0 And Tan(yy) >= 0) Then
yy = Abs(yy)
ElseIf (Sin(A12) >= 0 And Tan(yy) < 0) Then
yy = PI - Abs(yy)
ElseIf (Sin(A12) < 0 And Tan(yy) < 0) Then
yy = -Abs(yy)
Else
yy = Abs(yy) - PI
End If

L2 = L1 + yy - oo

A21 = Atn(cos_u1 * Sin(A12) / (cos_u1 * Cos(o) * Cos(A12) - sin_u1 * Sin(o)))
If (Sin(A12) >= 0 And Tan(A21) >= 0) Then
A21 = PI + Abs(A21)
ElseIf (Sin(A12) >= 0 And Tan(A21) < 0) Then
A21 = 2 * PI - Abs(A21)
ElseIf (Sin(A12) < 0 And Tan(A21) < 0) Then
A21 = PI - Abs(A21)
Else
A21 = Abs(A21)
End If
Text_B2.Text = Round(RadianToAngle(B2 + 0), 8)
Text_L2.Text = Round(RadianToAngle(L1 + yy - oo), 8)
'If (A12 < PI) Then
'A21 = A21 + PI
'Else
'A21 = A21 - PI
'End If
Text_A21.Text = Round(RadianToAngle(A21 + 0), 8)
Text_B2.BackColor = &H8000000E
Text_L2.BackColor = &H8000000E
Text_A21.BackColor = &H8000000E
Text_B2.Enabled = True
Text_L2.Enabled = True
Text_A21.Enabled = True
'Print 234234234234#
End If
End Sub



Private Sub Command2_Click()
Dim txt As String
'Dim txt() As Double
Dim i As Integer
CommonDialog1.ShowOpen
If (CommonDialog1.FileName <> "") Then
Open CommonDialog1.FileName For Input As #13
Dim ccc As Integer
ccc = 1
Do While Not EOF(13)
Line Input #13, txt
BBmat = Split(txt, ",", -1, 1)
Command3.Enabled = True
B1 = AngleToRadian(Val(BBmat(0))) ': Print B1
L1 = AngleToRadian(Val(BBmat(1))) ': Print L1
A12 = AngleToRadian(Val(BBmat(2))) ': Print A12
S = Val(BBmat(3))
W1 = GetW(B1 + 0)
sin_u1 = Sin(B1) * Sqr(1 - ee) / (W1 + 1E-36)
cos_u1 = Cos(B1) / (W1 + 1E-39)
sin_A0 = cos_u1 * Sin(A12): cot_o1 = cos_u1 * Cos(A12) / sin_u1: sin_2o1 = 2 * cot_o1 / (cot_o1 * cot_o1 + 1): cos_2o1 = (cot_o1 * cot_o1 - 1) / (cot_o1 * cot_o1 + 1)
cos_A0_2 = 1 - sin_A0 * sin_A0

kk = e_e * cos_A0_2
AA = b_b * (1 + kk / 4 - 3 * kk * kk / 64 + 5 * kk * kk * kk / 256)
BB = b_b * (kk / 8 - kk * kk / 32 + 15 * kk * kk * kk / 1024)
CC = b_b * (kk * kk / 128 - 3 * kk * kk * kk / 512)
aaa = (ee / 2 + ee * ee / 8 + ee * ee * ee / 16) - (ee * ee / 16 + ee * ee * ee / 16) * cos_A0_2 + (3 * ee * ee * ee / 128) * cos_A0_2 * cos_A0_2
bbb = (ee * ee / 32 + ee * ee * ee / 32) * cos_A0_2 - (ee * ee * ee / 64) * cos_A0_2 * cos_A0_2

o0 = (S - (BB + CC * cos_2o1) * sin_2o1) / (AA + 1E-16)
sin_2o1r0 = sin_2o1 * Cos((2 * o0)) + cos_2o1 * Sin((2 * o0))
cos_2o1r0 = cos_2o1 * Cos(2 * o0) - sin_2o1 * Sin(2 * o0)
o = o0 + (BB + 5 * CC * cos_2o1r0) * sin_2o1r0 / (AA + 1E-16)

oo = (aaa * o + bbb * (sin_2o1r0 - sin_2o1)) * sin_A0

sin_u2 = sin_u1 * Cos(o) + cos_u1 * Cos(A12) * Sin(o)
B2 = Atn(sin_u2 / (Sqr(1 - ee) * Sqr(1 - sin_u2 * sin_u2)))
yy = Atn(Sin(A12) * Sin(o) / (cos_u1 * Cos(o) - sin_u1 * Sin(o) * Cos(A12)))
If (Sin(A12) >= 0 And Tan(yy) >= 0) Then
yy = Abs(yy)
ElseIf (Sin(A12) >= 0 And Tan(yy) < 0) Then
yy = PI - Abs(yy)
ElseIf (Sin(A12) < 0 And Tan(yy) < 0) Then
yy = -Abs(yy)
Else
yy = Abs(yy) - PI
End If

L2 = L1 + yy - oo

A21 = Atn(cos_u1 * Sin(A12) / (cos_u1 * Cos(o) * Cos(A12) - sin_u1 * Sin(o)))
If (Sin(A12) >= 0 And Tan(A21) >= 0) Then
A21 = PI + Abs(A21)
ElseIf (Sin(A12) >= 0 And Tan(A21) < 0) Then
A21 = 2 * PI - Abs(A21)
ElseIf (Sin(A12) < 0 And Tan(A21) < 0) Then
A21 = PI - Abs(A21)
Else
A21 = Abs(A21)
End If
BBmat(0) = Round(RadianToAngle(B2 + 0), 8)
BBmat(1) = Round(RadianToAngle(L1 + yy - oo), 8)
BBmat(2) = Round(RadianToAngle(A21 + 0), 8)
ReDim Preserve CCmat(3, ccc)
For i = (ccc - 1) To ccc - 1
CCmat(0, i) = BBmat(0): CCmat(1, i) = BBmat(1): CCmat(2, i) = BBmat(2)
Next i
dd = ccc
ccc = ccc + 1
Loop
Close #13
End If

End Sub

Private Sub Command3_Click()
Dim i As Integer
Dim overwrite As Integer
CommonDialog1.ShowSave
If Dir(CommonDialog1.FileName) <> "" Then
overwrite = MsgBox("次文件已经存在，是否需要覆盖？", vbOKCancel)
If (overwrite = vbOK) Then
GoTo save
End If
Else
save: Open CommonDialog1.FileName For Output As #13
If (dd > 1) Then
For i = 0 To dd - 2
Print #13, CCmat(0, i) & "," & CCmat(1, i) + Chr(13)
Next i
Print #13, CCmat(0, dd - 1) & "," & CCmat(1, dd - 1)
Else
Print #13, CCmat(0, 0) & "," & CCmat(1, 0)
End If
Close #13
End If
End Sub

Private Sub Form_Click()
'Print AngleToRadian(-43.243523452345)
End Sub

Private Sub Form_Load()
Text_B2.BackColor = &H8000000B
Text_L2.BackColor = &H8000000B
Text_A21.BackColor = &H8000000B
Text_B2.Enabled = False
Text_L2.Enabled = False
Text_A21.Enabled = False
Command3.Enabled = False
End Sub



Private Sub Option1_Click()
a = 6378245
b_b = 6356863.01877305
c = 6399698.90178271
a_a = 1 / 298.3
ee = 0.006693421622966
e_e = 0.006738525414683
End Sub

Private Sub Option2_Click()
a = 6378140
b_b = 6356755.28815753
c = 6399596.65198801
a_a = 1 / 298.257
ee = 0.006694384999588
e_e = 0.006739501819473
End Sub

Private Sub Option3_Click()
a = 6378137
b_b = 6356752.3142
c = 6399593.6258
a_a = 1 / 298.257223563
ee = 0.0066943799013
e_e = 0.00673949674227
End Sub

Private Sub Return_Click()
FormBaselZ.Hide
End Sub



Private Sub Text_A12_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
      Case Asc("-") '允许负数
            If Text_A12.SelStart = 0 Then
              If Left(Text_A12.Text, 1) = "-" Then
                  KeyAscii = 0
                  Beep
              End If
            Else
              KeyAscii = 0
              Beep
            End If
        Case 8
              '无变化,退格键不屏蔽
        Case Asc(" ") '32
            If Text_A12.SelLength = 0 Then
                KeyAscii = 0
            End If
        Case Asc(".") '46 '允许小数点
            If InStr(Text_A12.Text, ".") Then
                KeyAscii = 0
            End If
        Case Is < Asc(0) '48
              KeyAscii = 0
        Case Is > Asc(9) '57
              KeyAscii = 0
  End Select
End Sub

Private Sub Text_B1_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
      Case Asc("-") '允许负数
            If Text_B1.SelStart = 0 Then
              If Left(Text_B1.Text, 1) = "-" Then
                  KeyAscii = 0
                  Beep
              End If
            Else
              KeyAscii = 0
              Beep
            End If
        Case 8
              '无变化,退格键不屏蔽
        Case Asc(" ") '32
            If Text_B1.SelLength = 0 Then
                KeyAscii = 0
            End If
        Case Asc(".") '46 '允许小数点
            If InStr(Text_B1.Text, ".") Then
                KeyAscii = 0
            End If
        Case Is < Asc(0) '48
              KeyAscii = 0
        Case Is > Asc(9) '57
              KeyAscii = 0
  End Select
End Sub

Private Sub Text_L1_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
      Case Asc("-") '允许负数
            If Text_L1.SelStart = 0 Then
              If Left(Text_L1.Text, 1) = "-" Then
                  KeyAscii = 0
                  Beep
              End If
            Else
              KeyAscii = 0
              Beep
            End If
        Case 8
              '无变化,退格键不屏蔽
        Case Asc(" ") '32
            If Text_L1.SelLength = 0 Then
                KeyAscii = 0
            End If
        Case Asc(".") '46 '允许小数点
            If InStr(Text_L1.Text, ".") Then
                KeyAscii = 0
            End If
        Case Is < Asc(0) '48
              KeyAscii = 0
        Case Is > Asc(9) '57
              KeyAscii = 0
  End Select
End Sub

Private Sub Text_S_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
      Case Asc("-") '允许负数
            If Text_S.SelStart = 0 Then
              If Left(Text_S.Text, 1) = "-" Then
                  KeyAscii = 0
                  Beep
              End If
            Else
              KeyAscii = 0
              Beep
            End If
        Case 8
              '无变化,退格键不屏蔽
        Case Asc(" ") '32
            If Text_S.SelLength = 0 Then
                KeyAscii = 0
            End If
        Case Asc(".") '46 '允许小数点
            If InStr(Text_S.Text, ".") Then
                KeyAscii = 0
            End If
        Case Is < Asc(0) '48
              KeyAscii = 0
        Case Is > Asc(9) '57
              KeyAscii = 0
  End Select
End Sub