📄 zbzhh.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Form1
Caption = "坐标批量转换"
ClientHeight = 3585
ClientLeft = 5115
ClientTop = 4095
ClientWidth = 4680
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 3585
ScaleWidth = 4680
Begin VB.ComboBox Combo1
Height = 300
Left = 2880
TabIndex = 12
Text = "Combo1"
Top = 2280
Width = 1215
End
Begin MSComDlg.CommonDialog ComDg1
Left = 3720
Top = 240
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton Command3
Caption = "转换"
Height = 375
Left = 2880
TabIndex = 11
Top = 2880
Width = 1215
End
Begin VB.CommandButton Command2
Caption = "取消"
Height = 375
Left = 480
TabIndex = 10
Top = 2880
Width = 1335
End
Begin VB.TextBox Text4
Alignment = 1 'Right Justify
Height = 270
Left = 3480
TabIndex = 8
Text = "0"
Top = 1680
Width = 375
End
Begin VB.TextBox Text3
Alignment = 1 'Right Justify
Height = 270
Left = 2640
TabIndex = 6
Text = "0"
Top = 1680
Width = 375
End
Begin VB.TextBox Text2
Alignment = 1 'Right Justify
Height = 270
Left = 1800
TabIndex = 4
Text = "120"
Top = 1680
Width = 495
End
Begin VB.CommandButton Command1
Caption = "浏览"
Height = 375
Left = 3480
TabIndex = 2
Top = 840
Width = 855
End
Begin VB.TextBox Text1
Alignment = 1 'Right Justify
Height = 375
Left = 240
TabIndex = 1
Text = "F:\kzhd.txt"
Top = 840
Width = 2895
End
Begin VB.Label Label6
Caption = "选择椭球参数"
Height = 375
Left = 600
TabIndex = 13
Top = 2280
Width = 1455
End
Begin VB.Label Label5
Caption = "秒"
Height = 255
Left = 3960
TabIndex = 9
Top = 1680
Width = 255
End
Begin VB.Label Label4
Caption = "分"
Height = 255
Left = 3120
TabIndex = 7
Top = 1680
Width = 255
End
Begin VB.Label Label3
Caption = "度"
Height = 255
Left = 2400
TabIndex = 5
Top = 1680
Width = 255
End
Begin VB.Label Label2
Alignment = 1 'Right Justify
Caption = "转换到中央经线"
Height = 255
Left = 240
TabIndex = 3
Top = 1680
Width = 1335
End
Begin VB.Label Label1
Alignment = 2 'Center
Caption = "坐标文件位置"
Height = 375
Left = 600
TabIndex = 0
Top = 240
Width = 3375
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const pi As Double = 3.14159265
Private Sub Command1_Click()
ComDg1.DialogTitle = "打开数据文件"
ComDg1.Filter = "Txt File|*.txt"
ComDg1.Action = 1
Text1.Text = ComDg1.FileName
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
Dim pname As String: Dim x As Double: Dim y As Double: Dim zhyhh As String
Dim datafile As String: Dim outfile As String
datafile = Text1.Text
zhyhh = Text2.Text & Text3.Text & Text4.Text
outfile = Mid(datafile, 1, Len(datafile) - 4) & zhyhh & ".txt"
Dim chr As Double: Dim dr As Double: Dim e1 As Double: Dim e2 As Double '定义椭球参数
Dim zhyjx As Double '中央经线
zhyjx = jdzhh(Val(Text2.Text) + Val(Text3.Text) / 60 + Val(Text4.Text) / 3600) '转为弧度
Call canshu(Combo1.ListIndex, chr, dr, e1, e2)
Dim bf As Double: '定义Bf参数
Open datafile For Input As #1
Open outfile For Output As #2
Do While Not EOF(1)
Input #1, pname, x, y
bf = bfdd(x)
Call jwd(bf, y, b, l) '解算经纬度
Call zbjs(b, l, xnew, ynew) '解算坐标
Print #2, pname & "," & xnew & "," & ynew
Loop
Close #1
Close #2
End Sub
Private Sub Form_Load()
Combo1.AddItem "1954年北京坐标系统"
Combo1.AddItem "1980年西安坐标系统"
Combo1.AddItem "WGS84坐标系统"
Combo1.Text = "1954年北京坐标系统"
End Sub
Private Sub Text2_LostFocus()
If IsNumeric(Text2.Text) Then
MsgBox "输入错误！", , "坐标转换"
Text2.SetFocus
End If
End Sub
Private Sub Text3_LostFocus()
If IsNumeric(Text3.Text) Then
MsgBox "输入错误！", , "坐标转换"
Text3.SetFocus
End If
End Sub
Private Sub Text4_LostFocus()
If IsNumeric(Text4.Text) Then
MsgBox "输入错误！", , "坐标转换"
Text4.SetFocus
End If
End Sub
Private Function jdzhh(jd)
jdzhh = jd / 180 * pi
End Function
Private Function jwd(bf1 As Double, ByVal y1 As Double, b1 As Double, L1 As Double)
Dim Mf As Double: Dim Nf As Double: Dim Tf As Double: Dim N1 As Double: Dim nf2 As Double
Dim dh As Integer: Dim Lo As Double
dh = 0: Lo = 120
If y1 > 1000000 Then
dh = Mid(y1, 1, 2)
y1 = y1 Mod 1000000 - 500000
Else:
y1 = y1 - 500000
End If
If dh <> 0 Then
Select Case dh
Case dh <= 30
Lo = dh * 6 - 3
Case dh > 30
Lo = dh * 3
End Select
End If
Mf = a * (1 - e1) / sqrt((1 - e1 * Sin(jdzhh(bf1)) * Sin(jdzhh(bf1))) * (1 - e1 * Sin(jdzhh(bf1)) * Sin(jdzhh(bf1))) * (1 - e1 * Sin(jdzhh(bf1)) * Sin(jdzhh(bf1))))
Nf = a / sqrt(1 - e1 * Sin(jdzhh(bf1)))
nf2 = e1 * Cos(jdzhh(bf1))
Tf = Tan(jdzhh(bf1))
N1 = y1 * Sqr(1 + Nf) / c
b1 = bf1 - (1 + Nf) * Tf / pi * (90 * N1 * N1 - 7.5 * (5 + 3 * Tf * Tf + Nf - 9 * Nf * Tf * Tf) * N1 * N1 * N1 * N1 + 0.25 * (61 + 90 * Tf * Tf + 45 * Tf * Tf * Tf * Tf) * N1 * N1 * N1 * N1 * N1 * N1)
L1 = Lo + (180 * N1 - 30 * (1 + 2 * Tf * Tf + Nf) * N1 * N1 * N1 + 1.5 * (5 + 28 * Tf * Tf + 24 * Tf * Tf * Tf * Tf) * N1 * N1 * N1 * N1 * N1) / (pi() * Cos(jdzhh(bf1)))
End Function
Private Function zbjs(b1 As Double, L1 As Double, x2 As Double, y2 As Double)
End Function
Public Function canshu(it As Integer, a As Double, b As Double, e1 As Double, e2 As Double)
Select Case it
Case 0
a = 6378245
b = 6356863.0188
e1 = 0.006693421622966
e2 = 0.006738525414683
Case 1
a = 6378140
b = 6356863.0188
b = 6356755.2882
e1 = 0.00669438499959
e2 = 0.00673950191947
Case 2
a = 6378137
b = 6356752.3142
e1 = 0.00669437999013
e2 = 0.006739496742227
End Select
End Function
Private Function bfdd(ByVal x As Double) '计算底点纬度
Dim aa2 As Double: Dim aa1 As Double
aa1 = x / 111134.8611: aa2 = aa1 + 0.5
While aa2 - aa1 > 0.00000001
aa2 = (x + (32005.7799 * Sin(jdzhh(aa1)) + 133.9238 * (Sin(jdzhh(aa1))) ^ 3 + 0.6973 * (Sin(aa1)) ^ 5 + 0.0039 * (Sin(jdzhh(aa1))) ^ 7) * Cos(jdzhh(aa1))) / 111134.8611
aa1 = aa2
Wend
bfdd = aa2
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -