formbaself.frm

用VB编写的水准平差软件

x = 2 * a_1 - cos_A0_2 * Cos(o)                     '  error                   '               '
aaa = (ee / 2 + ee * ee / 8 + ee * ee * ee / 16 + ee * ee * ee * ee / 32) - (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) * 2 ''''''''''''''''''''''''
oo = (aaa * o - bbb * x * Sin(o)) * sin_A0
If ((Abs(oo - oo0) * p_p) < 0.001) Then
yy = L + oo

kk = e_e * cos_A0_2
AA = b_b * (1 + kk / 4 - 3 * kk * kk / 64 + 5 * kk * kk * kk / 256)
BB = 2 * (b_b * (kk / 8 - kk * kk / 32 + 15 * kk * kk * kk / 1024)) / cos_A0_2
CC = 2 * (b_b * (kk * kk / 128 - 3 * kk * kk * kk / 512)) / (cos_A0_2 * cos_A0_2)
y = (cos_A0_2 * cos_A0_2 - 2 * x * x) * Cos(o)
S = AA * o + (BB * x + CC * y) * Sin(o)
PP = cos_u1 * Sin(yy): qq = b_1 * Cos(yy) - b_2
A21 = Atn(PP / qq)
If (PP >= 0 And qq >= 0) Then
A21 = Abs(A21)
ElseIf (PP >= 0 And qq < 0) Then
A21 = PI - Abs(A21)
ElseIf (PP < 0 And qq < 0) Then
A21 = PI + Abs(A21)
Else
A21 = 2 * PI - Abs(A21)
End If
If (A12 < PI) Then
A21 = A21 + PI
Else
A21 = A21 - PI
End If

Else
oo0 = oo
GoTo aaaa
End If
Text_A12.Text = Round(RadianToAngle(A12 + 0), 8)
Text_A21.Text = Round(RadianToAngle(A21 + 0), 8)
Text_S.Text = Round(S, 4)
'Print 245235
Text_A12.BackColor = &H8000000E
Text_A21.BackColor = &H8000000E
Text_S.BackColor = &H8000000E
Text_A12.Enabled = True
Text_A21.Enabled = True
Text_S.Enabled = True
End If
End Sub

Private Sub Command2_Click()
Dim txt As String
'Dim txt() As Double
Dim i As Integer
Dim p, q As Double
CommonDialog1.ShowOpen
If (CommonDialog1.FileName <> "") Then
Open CommonDialog1.FileName For Input As #14
Dim ccc As Integer
ccc = 1
Do While Not EOF(14)
Line Input #14, txt
BBmat = Split(txt, ",", -1, 1)
Command3.Enabled = True
B1 = AngleToRadian(Val(BBmat(0))) ': Print B1
L1 = AngleToRadian(Val(BBmat(1))) ': Print L1
B2 = AngleToRadian(Val(BBmat(2))) ': Print B2
L2 = AngleToRadian(Val(BBmat(3))) ': Print L2
W1 = GetW(B1 + 0): W2 = GetW(B2 + 0)
sin_u1 = Sin(B1) * Sqr(1 - ee) / W1: sin_u2 = Sin(B2) * Sqr(1 - ee) / W2
cos_u1 = Cos(B1) / W1: cos_u2 = Cos(B2) / W2
L = L2 - L1
a_1 = sin_u1 * sin_u2: a_2 = cos_u1 * cos_u2
b_1 = cos_u1 * sin_u2: b_2 = sin_u1 * cos_u2
oo0 = 0
aaaa: yy = L + oo0
p = cos_u2 * Sin(yy): q = b_1 - b_2 * Cos(yy)
A12 = Atn(p / q)
If (p >= 0 And q >= 0) Then
A12 = Abs(A12)
ElseIf (p >= 0 And q < 0) Then
A12 = PI - Abs(A12)
ElseIf (p < 0 And q < 0) Then
A12 = PI + Abs(A12)
Else
A12 = 2 * PI - Abs(A12)
End If
sin_o = p * Sin(A12) + q * Cos(A12): cos_o = a_1 + a_2 * Cos(yy)
o = Atn(sin_o / cos_o)
If (cos_o >= 0) Then
o = Abs(o)
Else
o = PI - Abs(o)
End If
sin_A0 = cos_u1 * Sin(A12)
cos_A0_2 = 1 - sin_A0 * sin_A0
x = 2 * a_1 - cos_A0_2 * Cos(o)
aaa = (ee / 2 + ee * ee / 8 + ee * ee * ee / 16 + ee * ee * ee * ee / 32) - (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) * 2
oo = (aaa * o - bbb * x * Sin(o)) * sin_A0
If ((Abs(oo - oo0) * p_p) < 0.001) Then
yy = L + oo



kk = e_e * cos_A0_2
AA = b_b * (1 + kk / 4 - 3 * kk * kk / 64 + 5 * kk * kk * kk / 256)
BB = 2 * (b_b * (kk / 8 - kk * kk / 32 + 15 * kk * kk * kk / 1024)) / cos_A0_2
CC = 2 * (b_b * (kk * kk / 128 - 3 * kk * kk * kk / 512)) / (cos_A0_2 * cos_A0_2)
y = (cos_A0_2 * cos_A0_2 - 2 * x * x) * Cos(o)
S = AA * o + (BB * x + CC * y) * Sin(o)
PP = cos_u1 * Sin(yy): qq = b_1 * Cos(yy) - b_2
A21 = Atn(PP / qq)
If (PP >= 0 And qq >= 0) Then
A21 = Abs(A21)
ElseIf (PP >= 0 And qq < 0) Then
A21 = PI - Abs(A21)
ElseIf (PP < 0 And qq < 0) Then
A21 = PI + Abs(A21)
Else
A21 = 2 * PI - Abs(A21)
End If
If (A12 < PI) Then
A21 = A21 + PI
Else
A21 = A21 - PI
End If

Else
oo0 = oo
GoTo aaaa
End If
BBmat(0) = Round(RadianToAngle(A12 + 0), 8)
BBmat(1) = Round(RadianToAngle(A21 + 0), 8)
BBmat(2) = Round(S, 4)
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 #14
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 #14
If (dd > 1) Then
For i = 0 To dd - 2
Print #14, CCmat(0, i) & "," & CCmat(1, i) + Chr(13)
Next i
Print #14, CCmat(0, dd - 1) & "," & CCmat(1, dd - 1)
Else
Print #14, CCmat(0, 0) & "," & CCmat(1, 0)
End If
Close #14
End If
End Sub

Private Sub Form_Click()
'Print RadianToAngle(0.822062910707468)
'Print AngleToRadian(-7.0338945)
End Sub

Private Sub Form_Load()
Text_A12.BackColor = &H8000000B
Text_A21.BackColor = &H8000000B
Text_S.BackColor = &H8000000B
Text_A12.Enabled = False
Text_A21.Enabled = False
Text_S.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()
FormBaselF.Hide
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_B2_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
      Case Asc("-") '允许负数
            If Text_B2.SelStart = 0 Then
              If Left(Text_B2.Text, 1) = "-" Then
                  KeyAscii = 0
                  Beep
              End If
            Else
              KeyAscii = 0
              Beep
            End If
        Case 8
              '无变化,退格键不屏蔽
        Case Asc(" ") '32
            If Text_B2.SelLength = 0 Then
                KeyAscii = 0
            End If
        Case Asc(".") '46 '允许小数点
            If InStr(Text_B2.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_L2_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
      Case Asc("-") '允许负数
            If Text_L2.SelStart = 0 Then
              If Left(Text_L2.Text, 1) = "-" Then
                  KeyAscii = 0
                  Beep
              End If
            Else
              KeyAscii = 0
              Beep
            End If
        Case 8
              '无变化,退格键不屏蔽
        Case Asc(" ") '32
            If Text_L2.SelLength = 0 Then
                KeyAscii = 0
            End If
        Case Asc(".") '46 '允许小数点
            If InStr(Text_L2.Text, ".") Then
                KeyAscii = 0
            End If
        Case Is < Asc(0) '48
              KeyAscii = 0
        Case Is > Asc(9) '57
              KeyAscii = 0
  End Select
End Sub