guassprojectionz.frm

用VB编写的水准平差软件

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form GuassProjectionZ 
   Caption         =   "高斯投影坐标正算"
   ClientHeight    =   5850
   ClientLeft      =   4710
   ClientTop       =   3495
   ClientWidth     =   9870
   LinkTopic       =   "Form1"
   ScaleHeight     =   5850
   ScaleWidth      =   9870
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   8640
      Top             =   240
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Frame Frame1 
      Caption         =   "批量处理"
      Height          =   1575
      Left            =   1440
      TabIndex        =   15
      Top             =   3840
      Width           =   6735
      Begin VB.CommandButton Command3 
         Caption         =   "文件另存为"
         Height          =   495
         Left            =   3840
         TabIndex        =   17
         Top             =   480
         Width           =   1815
      End
      Begin VB.CommandButton Command2 
         Caption         =   "打开文件-->>>处理"
         Height          =   495
         Left            =   840
         TabIndex        =   16
         Top             =   480
         Width           =   1935
      End
   End
   Begin VB.CommandButton Command1 
      Caption         =   "---->>>>>>"
      Height          =   375
      Left            =   3840
      TabIndex        =   7
      Top             =   3000
      Width           =   1575
   End
   Begin VB.TextBox Text_Y 
      Height          =   375
      Left            =   6240
      TabIndex        =   12
      Top             =   3000
      Width           =   1575
   End
   Begin VB.TextBox Text_X 
      Height          =   375
      Left            =   6240
      TabIndex        =   11
      Top             =   2280
      Width           =   1575
   End
   Begin VB.OptionButton Option3 
      Caption         =   "WGS-84椭球体"
      Height          =   495
      Left            =   6600
      TabIndex        =   2
      Top             =   1200
      Width           =   2655
   End
   Begin VB.OptionButton Option2 
      Caption         =   "1975国际椭球体"
      Height          =   495
      Left            =   3840
      TabIndex        =   1
      Top             =   1200
      Width           =   2535
   End
   Begin VB.OptionButton Option1 
      Caption         =   "克拉索夫斯基椭球体"
      Height          =   495
      Left            =   1080
      TabIndex        =   0
      Top             =   1200
      Width           =   2535
   End
   Begin VB.TextBox Text_L0 
      Height          =   375
      Left            =   3840
      TabIndex        =   6
      Text            =   "111"
      Top             =   2400
      Width           =   1575
   End
   Begin VB.TextBox Text_L 
      Height          =   375
      Left            =   1440
      TabIndex        =   5
      Text            =   "111.285215387"
      Top             =   3000
      Width           =   1575
   End
   Begin VB.TextBox Text_B 
      Height          =   375
      Left            =   1440
      TabIndex        =   3
      Text            =   "22.155898294"
      Top             =   2280
      Width           =   1575
   End
   Begin VB.Label Label6 
      Caption         =   "y"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   8160
      TabIndex        =   14
      Top             =   3000
      Width           =   1455
   End
   Begin VB.Label Label5 
      Caption         =   "x"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   8160
      TabIndex        =   13
      Top             =   2280
      Width           =   1215
   End
   Begin VB.Label Label4 
      Caption         =   "L0"
      Height          =   375
      Left            =   4440
      TabIndex        =   10
      Top             =   1920
      Width           =   735
   End
   Begin VB.Label Label3 
      Caption         =   "L"
      Height          =   375
      Left            =   840
      TabIndex        =   9
      Top             =   3120
      Width           =   2175
   End
   Begin VB.Label Label2 
      Caption         =   "B"
      Height          =   375
      Left            =   840
      TabIndex        =   8
      Top             =   2280
      Width           =   1815
   End
   Begin VB.Label Label1 
      Caption         =   "高斯投影坐标正算"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   24
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   975
      Left            =   3120
      TabIndex        =   4
      Top             =   240
      Width           =   4935
   End
   Begin VB.Menu Return 
      Caption         =   "返回主页"
   End
End
Attribute VB_Name = "GuassProjectionZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim a As Double
Dim b_b As Double
Dim c As Double
Dim a_a As Double
Dim ee As Double
Dim e_e As Double
Const PI = 3.14159265358979
Const p = 206264.806247096
Public BBmat
Dim CCmat() As Variant
Dim dd As Double
Public Function AngleToRadian(angle As Double) As Double                '角度化弧度
Dim d As Integer
Dim f As Integer
Dim m As Double
angle = angle + 0.0000000001
d = Int(Abs(angle)) * Sgn(angle)
f = Int(Abs((angle - d) * 100)) * Sgn((angle - d) * 100)
m = ((angle - d) * 100 - f) * 100
'Print d
'Print f
'Print m
AngleToRadian = (CDbl(m) / 3600 + CDbl(f) / 60 + CDbl(d)) * PI / 180
'AngleToRadian = Sgn(angle) * AngleToRadian
'Print AngleToRadian
End Function

Public Function GetV(B As Double) As Double   '其中B为弧度V
GetV = Sqr(1 + e_e * Cos(B) * Cos(B))
'Print B
'Print e_e
'Print Sqr(1 + e_e * Cos(B) * Cos(B))
End Function

Public Function Getnn(B As Double) As Double          '其中B为弧度nnm
Getnn = e_e * Cos(B) * Cos(B)
End Function


Public Function GetN(B As Double) As Double     '其中B为弧度N
Dim V As Double
V = GetV(B)
GetN = c / V
End Function

Public Function Gett(B As Double) As Double        '其中B为弧度t
Gett = Tan(B)
End Function

Public Function RadianToAngle(radian As Double) As Double              '弧度化角度
Dim angle As Double
Dim d As Double
Dim f As Double
Dim m As Double
Do While (radian > (2 * PI))
radian = radian - 2 * PI
Loop
'Do While (radian < 0)
'radian = radian + 2 * PI
'Loop
angle = radian * 180 / PI
d = Int(Abs(angle)) * Sgn(angle)
f = Int(Abs((angle - d) * 60)) * Sgn((angle - d) * 60)
m = ((angle - d) * 60 - f) * 60
RadianToAngle = CDbl(d) + CDbl(f) / 100 + m / 10000
'RadianToAngle = Sgn(radian) * RadianToAngle
End Function

Private Sub Command1_Click()
If (e_e = 0) Then
MsgBox ("请选择椭球体的类型")
ElseIf (Text_B.Text = "") Then
MsgBox ("请填入纬度值")
ElseIf (Text_L.Text = "") Then
MsgBox ("请填入经度值")
ElseIf (Text_L0.Text = "") Then
MsgBox ("请填入投影带主子午线经度值")
Else
Dim B, L, L0, dl, n, t, m, nnm, X0, x, y As Double
Dim A0, B0, C0, D0, E0 As Double
B = AngleToRadian(Val(Text_B.Text))
L = AngleToRadian(Val(Text_L.Text))
L0 = AngleToRadian(Val(Text_L0.Text))
dl = L - L0
t = Gett(B + 0)
nnm = Getnn(B + 0)
n = GetN(B + 0)
m = Cos(B) * dl
d = b_b * b_b / a  'print d
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)
X0 = A0 * B - (B0 * Sin(B) + C0 * Sin(B) * Sin(B) * Sin(B) + D0 * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B) + E0 * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B)) * Cos(B)
x = X0 + n * t * (1 / 2 * m * m + 1 / 24 * (5 - t * t + 9 * nnm + 4 * nnm * nnm) * m * m * m * m + 1 / 720 * (61 - 58 * t * t + t * t * t * t + 270 * nnm - 330 * nnm * t * t) * m * m * m * m * m * m)
y = n * (m + 1 / 6 * (1 - t * t + nnm) * m * m * m + 1 / 120 * (5 - 18 * t * t + t * t * t * t + 14 * nnm - 58 * nnm * t * t) * m * m * m * m * m)
Text_X.Text = Round(x, 4)
Text_Y.Text = Round(y, 4)

Text_Y.BackColor = &H8000000E
Text_X.BackColor = &H8000000E
Text_X.Enabled = True
Text_Y.Enabled = True
Text_B.Enabled = True
Text_L.Enabled = True
End If
End Sub

Private Sub Command2_Click()
Text_B.Enabled = False
Text_L.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
B = AngleToRadian(Val(BBmat(0) + 0) + 0)
L = AngleToRadian(Val(BBmat(1) + 0) + 0)
L0 = AngleToRadian(Val(Text_L0.Text))
dl = L - L0
t = Gett(B + 0)
nnm = Getnn(B + 0)
n = GetN(B + 0)
m = Cos(B) * dl
d = b_b * b_b / a  'print d
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)
X0 = A0 * B - (B0 * Sin(B) + C0 * Sin(B) * Sin(B) * Sin(B) + D0 * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B) + E0 * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B) * Sin(B)) * Cos(B)
x = X0 + n * t * (1 / 2 * m * m + 1 / 24 * (5 - t * t + 9 * nnm + 4 * nnm * nnm) * m * m * m * m + 1 / 720 * (61 - 58 * t * t + t * t * t * t + 270 * nnm - 330 * nnm * t * t) * m * m * m * m * m * m)
y = n * (m + 1 / 6 * (1 - t * t + nnm) * m * m * m + 1 / 120 * (5 - 18 * t * t + t * t * t * t + 14 * nnm - 58 * nnm * t * t) * m * m * m * m * m)
BBmat(0) = Round(x, 4)
BBmat(1) = Round(y, 4)


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


Private Sub Form_Load()
Text_X.BackColor = &H8000000B
Text_Y.BackColor = &H8000000B
Text_X.Enabled = False
Text_Y.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()
GuassProjectionZ.Hide
End Sub


Private Sub Text_B_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_L_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_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