guassprojectionf.frm

用VB编写的水准平差软件

MsgBox ("请填入平面坐标 X")
ElseIf (Text_Y.Text = "") Then
MsgBox ("请填入平面坐标 Y")
ElseIf (Text_L0.Text = "") Then
MsgBox ("请填入投影带主子午线经度值")
Else
Dim B, L, x, y, X0, Bf, Bf0, n, Nf, nnf, tf, dl, d As Double
Dim A0, B0, C0, D0, E0, F_B As Double
x = Val(Text_X.Text)
y = Val(Text_Y.Text)
L0 = AngleToRadian(Val(Text_L0.Text))
d = b_b * b_b / a
A0 = d * (1 + 3 / 4 * ee + 45 / 64 * ee * ee + 175 / 256 * ee * ee * ee + 11025 / 16384 * ee * ee * ee * ee)
B0 = d * (3 / 4 * ee + 45 / 64 * ee * ee + 175 / 256 * ee * ee * ee + 11025 / 16384 * ee * ee * ee * ee)
C0 = d * (15 / 32 * ee * ee + 175 / 384 * ee * ee * ee + 3675 / 8192 * ee * ee * ee * ee)
D0 = d * (35 / 96 * ee * ee * ee + 735 / 2048 * ee * ee * ee * ee)
E0 = d * (315 / 1024 * ee * ee * ee * ee)

Bf0 = x / A0

asdf: 'X0 = A0 * Bf0 - (B0 * Sin(Bf0) + C0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + D0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + E0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0)) * Cos(Bf0)
      F_B = -((B0 * Sin(Bf0) + C0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + D0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + E0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0)) * Cos(Bf0))
      Bf = (x - F_B) / A0

    If (Abs(Bf - Bf0) * p < 0.00001) Then
    nnf = Getnn(Bf + 0)
    tf = Gett(Bf + 0)
    n = y / GetN(Bf + 0)
    B = Bf - (1 + nnf) * tf / 180 * (90 * n * n - 7.5 * (5 + 3 * tf * tf + nnf - 9 * nnf * tf * tf) * n * n * n * n + 0.25 * (61 + 90 * tf * tf + 45 * tf * tf * tf * tf) * n * n * n * n * n * n)
    dl = 1 / (180 * Cos(Bf)) * (180 * n - 30 * (1 + 2 * tf * tf + nnf) * n * n * n + 1.5 * (5 + 28 * tf * tf + 24 * tf * tf * tf * tf) * n * n * n * n * n)
    L = dl + L0
    Text_B.Text = Round(RadianToAngle(B + 0), 9)
    Text_L.Text = Round(RadianToAngle(L + 0), 9)
    Else
    Bf0 = Bf
    GoTo asdf
End If
Text_B.BackColor = &H8000000E
Text_L.BackColor = &H8000000E
Text_B.Enabled = True
Text_L.Enabled = True
Text_X.Enabled = True
Text_Y.Enabled = True
End If
End Sub

Private Sub Command2_Click()
Text_X.Enabled = False
Text_Y.Enabled = False

If (Text_L0.Text = "") Then
MsgBox ("请输入此带中央子午线的精度！！！")
Text_L0.SetFocus
Else
Dim txt As String
'Dim txt() As Double
Dim i As Integer
CommonDialog1.ShowOpen
If (CommonDialog1.FileName <> "") Then
Open CommonDialog1.FileName For Input As #21
Dim ccc As Integer
ccc = 1
Do While Not EOF(21)
Line Input #21, txt
BBmat = Split(txt, ",", -1, 1)
Command3.Enabled = True
x = Val(BBmat(0))
y = Val(BBmat(1))
L0 = AngleToRadian(Val(Text_L0.Text))
d = b_b * b_b / a
A0 = d * (1 + 3 / 4 * ee + 45 / 64 * ee * ee + 175 / 256 * ee * ee * ee + 11025 / 16384 * ee * ee * ee * ee)
B0 = d * (3 / 4 * ee + 45 / 64 * ee * ee + 175 / 256 * ee * ee * ee + 11025 / 16384 * ee * ee * ee * ee)
C0 = d * (15 / 32 * ee * ee + 175 / 384 * ee * ee * ee + 3675 / 8192 * ee * ee * ee * ee)
D0 = d * (35 / 96 * ee * ee * ee + 735 / 2048 * ee * ee * ee * ee)
E0 = d * (315 / 1024 * ee * ee * ee * ee)

Bf0 = x / A0

asdf: 'X0 = A0 * Bf0 - (B0 * Sin(Bf0) + C0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + D0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + E0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0)) * Cos(Bf0)
      F_B = -((B0 * Sin(Bf0) + C0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + D0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) + E0 * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0) * Sin(Bf0)) * Cos(Bf0))
      Bf = (x - F_B) / A0

    If (Abs(Bf - Bf0) * p < 0.00001) Then
    nnf = Getnn(Bf + 0)
    tf = Gett(Bf + 0)
    n = y / GetN(Bf + 0)
    B = Bf - (1 + nnf) * tf / 180 * (90 * n * n - 7.5 * (5 + 3 * tf * tf + nnf - 9 * nnf * tf * tf) * n * n * n * n + 0.25 * (61 + 90 * tf * tf + 45 * tf * tf * tf * tf) * n * n * n * n * n * n)
    dl = 1 / (180 * Cos(Bf)) * (180 * n - 30 * (1 + 2 * tf * tf + nnf) * n * n * n + 1.5 * (5 + 28 * tf * tf + 24 * tf * tf * tf * tf) * n * n * n * n * n)
    L = dl + L0
    BBmat(0) = Round(RadianToAngle(B + 0), 9)
    BBmat(1) = Round(RadianToAngle(L + 0), 9)
    Else
    Bf0 = Bf
    GoTo asdf
End If

ReDim Preserve CCmat(2, ccc)
For i = (ccc - 1) To ccc - 1
CCmat(0, i) = BBmat(0): CCmat(1, i) = BBmat(1)
Next i

dd = ccc
ccc = ccc + 1


Loop
Close #21
End If
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 #21
If (dd > 1) Then
For i = 0 To dd - 2
Print #21, CCmat(0, i) & "," & CCmat(1, i) + Chr(13)
Next i
Print #21, CCmat(0, dd - 1) & "," & CCmat(1, dd - 1)
Else
Print #21, CCmat(0, 0) & "," & CCmat(1, 0)
End If
Close #21
End If
End Sub

Private Sub Form_Load()
Text_B.BackColor = &H8000000B
Text_L.BackColor = &H8000000B
Text_B.Enabled = False
Text_L.Enabled = False
CommonDialog1.Filter = "*.txt"
CommonDialog1.DefaultExt = "txt"
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()
GuassProjectionF.Hide
End Sub




Private Sub Text_L0_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

Private Sub Text_X_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



Private Sub Text_Y_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