formguassz.frm

用VB编写的水准平差软件

Dim dA1 As Double
b1 = AngleToRadian(Val(Text_B1.Text)) ': Print B1
L1 = AngleToRadian(Val(Text_L1.Text)) ': Print L1
A12 = AngleToRadian(Val(Text_A12.Text)) ': Print A12
S12 = Val(Text_S.Text)
m1 = GetM(b1)
n1 = GetN(b1)
dB0 = S12 * Cos(A12) / m1
dL0 = S12 * Sin(A12) / (n1 * Cos(b1))
dA0 = dL0 * Sin(b1)
a: Bm = b1 + dB0 / 2
Lm = L1 + dL0 / 2
Am = A12 + dA0 / 2
Vm = GetV(Bm)
Nm = GetN(Bm)
nnm = Getnn(Bm)
tm = Gett(Bm)

dB1 = Vm * Vm * S12 * Cos(Am) / Nm * (1 + S12 * S12 / (24 * Nm * Nm) * (Sin(Am) * Sin(Am) * (2 + 3 * tm * tm + 2 * nnm) + 3 * nnm * Cos(Am) * Cos(Am) * (-1 + tm * tm - nnm - 4 * tm * tm * nnm)))
dL1 = S12 * Sin(Am) / (Cos(Bm) * Nm) * (1 + S12 * S12 / (24 * Nm * Nm) * (Sin(Am) * Sin(Am) * tm * tm - Cos(Am) * Cos(Am) * (1 + nnm - 9 * tm * tm * nnm)))
dA1 = S12 * Sin(Am) * tm / Nm * (1 + S12 * S12 / (24 * Nm * Nm) * (Cos(Am) * Cos(Am) * (2 + 7 * nnm + 9 * tm * tm * nnm + 5 * nnm * nnm) + Sin(Am) * Sin(Am) * (2 + tm * tm + 2 * nnm)))
If ((Abs(dB1 - dB0) * p) < 0.0001 And (Abs(dL1 - dL0) * p) < 0.0001 And (Abs(dA1 - dA0) * p) < 0.0001) Then
Text_B2.Text = Round(RadianToAngle(b1 + dB0), 8)
Text_L2.Text = Round(RadianToAngle(L1 + dL0), 8)
    If (A12 < PI) Then
    Text_A21.Text = Round(RadianToAngle(A12 + dA0 + PI), 8)
    Else
    Text_A21.Text = Round(RadianToAngle(A12 + dA0 - PI), 8)
    End If

Else
dB0 = dB1
dL0 = dL1
dA0 = dA1
GoTo a
'Text_B2.Text = 0
'Text_L2.Text = 0
'Text_A21.Text = 0
End If
Text_B2.Enabled = True
Text_L2.Enabled = True
Text_A21.Enabled = True
Text_B2.BackColor = &H8000000E
Text_L2.BackColor = &H8000000E
Text_A21.BackColor = &H8000000E
End If

End Sub

Public 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 #11
Dim ccc As Integer
ccc = 1
Do While Not EOF(11)
Line Input #11, txt



BBmat = Split(txt, ",", -1, 1)
Command4.Enabled = True
b1 = AngleToRadian(Val(BBmat(0)))  ': Print B1
L1 = AngleToRadian(Val(BBmat(1)))  ': Print L1
A12 = AngleToRadian(Val(BBmat(2)))  ': Print A12
S12 = Val(BBmat(3))
m1 = GetM(b1 + 0)
n1 = GetN(b1 + 0)
dB0 = S12 * Cos(A12) / m1
dL0 = S12 * Sin(A12) / (n1 * Cos(b1))
dA0 = dL0 * Sin(b1)
a: Bm = b1 + dB0 / 2
Lm = L1 + dL0 / 2
Am = A12 + dA0 / 2
Vm = GetV(Bm + 0)
Nm = GetN(Bm + 0)
nnm = Getnn(Bm + 0)
tm = Gett(Bm + 0)

dB1 = Vm * Vm * S12 * Cos(Am) / Nm * (1 + S12 * S12 / (24 * Nm * Nm) * (Sin(Am) * Sin(Am) * (2 + 3 * tm * tm + 2 * nnm) + 3 * nnm * Cos(Am) * Cos(Am) * (-1 + tm * tm - nnm - 4 * tm * tm * nnm)))
dL1 = S12 * Sin(Am) / (Cos(Bm) * Nm) * (1 + S12 * S12 / (24 * Nm * Nm) * (Sin(Am) * Sin(Am) * tm * tm - Cos(Am) * Cos(Am) * (1 + nnm - 9 * tm * tm * nnm)))
dA1 = S12 * Sin(Am) * tm / Nm * (1 + S12 * S12 / (24 * Nm * Nm) * (Cos(Am) * Cos(Am) * (2 + 7 * nnm + 9 * tm * tm * nnm + 5 * nnm * nnm) + Sin(Am) * Sin(Am) * (2 + tm * tm + 2 * nnm)))
If ((Abs(dB1 - dB0) * p) < 0.0001 And (Abs(dL1 - dL0) * p) < 0.0001 And (Abs(dA1 - dA0) * p) < 0.0001) Then
BBmat(0) = Round(RadianToAngle(b1 + dB0), 8)
BBmat(1) = Round(RadianToAngle(L1 + dL0), 8)
    If (A12 < PI) Then
    BBmat(2) = Round(RadianToAngle(A12 + dA0 + PI), 8)
    Else
    BBmat(2) = Round(RadianToAngle(A12 + dA0 - PI), 8)
    End If
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
Else
dB0 = dB1
dL0 = dL1
dA0 = dA1
GoTo a
'Text_B2.Text = 0
'Text_L2.Text = 0
'Text_A21.Text = 0
End If
dd = ccc
ccc = ccc + 1


Loop
Close #11
End If

End Sub

Public Sub Command4_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 #11
If (dd > 1) Then
For i = 0 To dd - 2
Print #11, CCmat(0, i) & "," & CCmat(1, i) + Chr(13)
Next i
Print #11, CCmat(0, dd - 1) & "," & CCmat(1, dd - 1)
Else
Print #11, CCmat(0, 0) & "," & CCmat(1, 0)
End If
Close #11
End If
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
CommonDialog1.Filter = "*.txt"
CommonDialog1.DefaultExt = "txt"
Command4.Enabled = False
End Sub


Private Sub Option1_Click()
a = 6378245
'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 = 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 = 6356752.3142
c = 6399593.6258
a_a = 1 / 298.257223563
ee = 0.0066943799013
e_e = 0.00673949674227
End Sub

Private Sub Form_Click()
'Dim p As Variant
'p = AngleToRadian(234.524235)
'q = GetM(45)
'Print p
'Print q

End Sub

Private Sub Return_Click()
FormGuassZ.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