📄 zhuanhuan.frm
字号:
Strikethrough = 0 'False
EndProperty
Height = 2895
Left = -70200
TabIndex = 4
Top = 1200
Width = 4335
Begin VB.TextBox TextKJ
BeginProperty Font
Name = "黑体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 2
Left = 600
TabIndex = 7
Top = 2040
Width = 3135
End
Begin VB.TextBox TextKJ
BeginProperty Font
Name = "黑体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 1
Left = 600
TabIndex = 6
Top = 1320
Width = 3135
End
Begin VB.TextBox TextKJ
BeginProperty Font
Name = "黑体"
Size = 14.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 0
Left = 600
TabIndex = 5
Top = 480
Width = 3135
End
Begin VB.Label Label6
BackStyle = 0 'Transparent
Caption = "Z"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 10
Top = 2160
Width = 255
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Caption = "Y"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 9
Top = 1440
Width = 255
End
Begin VB.Label Label4
BackStyle = 0 'Transparent
Caption = "X"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 240
TabIndex = 8
Top = 600
Width = 255
End
End
Begin VB.CommandButton Cmdcle
Caption = "清空"
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = -66720
TabIndex = 3
Top = 4920
Width = 735
End
Begin VB.CommandButton Cmdend
Caption = "退出"
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = -66720
TabIndex = 2
Top = 5640
Width = 735
End
Begin VB.CommandButton Command1
Caption = "测试"
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = -66720
TabIndex = 1
Top = 4440
Width = 735
End
Begin VB.Label Label7
Caption = "大地坐标与空间直角坐标 正反算"
BeginProperty Font
Name = "楷体_GB2312"
Size = 21.75
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = -74040
TabIndex = 24
Top = 480
Width = 6975
End
End
End
Attribute VB_Name = "坐标转换"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public XAa, XAb, XAc, XAe2, XAe12 As Double '1975国际椭球体（80西安坐标系）参数
Public BJa, BJb, BJc, BJe2, BJe12 As Double '克拉索夫椭球体（北京54坐标系）参数
Public WGSa, WGSb, WGSc, WGSe2, WGSe12 As Double 'WGS-84椭球体（GPS）参数
Public PI As Double '辅助量
Private Sub Cmdcle_Click()
TextDD(0).Text = ""
TextDD(1).Text = ""
TextDD(2).Text = ""
TextKJ(0).Text = ""
TextKJ(1).Text = ""
TextKJ(2).Text = ""
End Sub
Private Sub Cmdend_Click()
End
End Sub
Private Sub Command1_Click()
TextDD(0).Text = 45.09112907
TextDD(1).Text = 30
TextDD(2).Text = 1632465.589
TextKJ(0).Text = 4898979.486
TextKJ(1).Text = 2828427.125
TextKJ(2).Text = 5656854.248
End Sub
'大地转空间54坐标系
Private Sub DK5_Click()
Dim a, e2, N, Ba, Br, La, Lr, H, X, Y, Z, tgB, tgB1 As Double
a = BJa
e2 = BJe2
H = Val(TextDD(2).Text)
Br = Rad(TextDD(0).Text)
Lr = Rad(TextDD(1).Text)
N = a / Sqr(1 - e2 * (Sin(Br)) ^ 2)
X = (N + H) * Cos(Br) * Cos(Lr)
Y = (N + H) * Cos(Br) * Sin(Lr)
Z = (N * (1 - e2) + H) * Sin(Br)
TextKJ(0).Text = Round(X, 3)
TextKJ(1).Text = Round(Y, 3)
TextKJ(2).Text = Round(Z, 3)
End Sub
'大地转空间80坐标系
Private Sub DK8_Click()
Dim a, e2, N, Ba, Br, La, Lr, H, X, Y, Z, tgB, tgB1 As Double
a = XAa
e2 = XAe2
H = Val(TextDD(2).Text)
Br = Rad(TextDD(0).Text)
Lr = Rad(TextDD(1).Text)
N = a / Sqr(1 - e2 * (Sin(Br)) ^ 2)
X = (N + H) * Cos(Br) * Cos(Lr)
Y = (N + H) * Cos(Br) * Sin(Lr)
Z = (N * (1 - e2) + H) * Sin(Br)
TextKJ(0).Text = Round(X, 3)
TextKJ(1).Text = Round(Y, 3)
TextKJ(2).Text = Round(Z, 3)
End Sub
'空间转大地54坐标系
Private Sub KD5_Click()
Dim B(), tgB() As Double
Dim Ba, Br, La, Lr As Double
a = BJa
e2 = BJe2
X = Val(TextKJ(0).Text)
Y = Val(TextKJ(1).Text)
Z = Val(TextKJ(2).Text)
Lr = Atn(Y / X)
ReDim B(1)
ReDim tgB(1)
tgB(0) = Z / Sqr(X ^ 2 + Y ^ 2)
B(0) = Atn(tgB(0))
i = 0
Do
N = a / Sqr(1 - e2 * (Sin(B(i))) ^ 2)
tgB(i + 1) = (Z + N * e2 * Sin(B(i))) / Sqr(X ^ 2 + Y ^ 2)
B(i + 1) = Atn(tgB(i + 1))
i = i + 1
ReDim Preserve tgB(i + 1)
ReDim Preserve B(i + 1)
Loop Until Abs(tgB(i) - tgB(i - 1)) < 10 ^ -7
H = Sqr(X ^ 2 + Y ^ 2) / Cos(B(i)) - N
Br = B(i)
Ba = Txt(Br)
La = Txt(Lr)
TextDD(0).Text = Ba
TextDD(1).Text = La
TextDD(2).Text = Round(H, 3)
End Sub
'空间转大地80坐标系
Private Sub KD8_Click()
Dim B(), tgB() As Double
Dim Ba, Br, La, Lr As Double
a = XAa
e2 = XAe2
X = Val(TextKJ(0).Text)
Y = Val(TextKJ(1).Text)
Z = Val(TextKJ(2).Text)
Lr = Atn(Y / X)
ReDim B(1)
ReDim tgB(1)
tgB(0) = Z / Sqr(X ^ 2 + Y ^ 2)
B(0) = Atn(tgB(0))
i = 0
Do
N = a / Sqr(1 - e2 * (Sin(B(i))) ^ 2)
tgB(i + 1) = (Z + N * e2 * Sin(B(i))) / Sqr(X ^ 2 + Y ^ 2)
B(i + 1) = Atn(tgB(i + 1))
i = i + 1
ReDim Preserve tgB(i + 1)
ReDim Preserve B(i + 1)
Loop Until Abs(tgB(i) - tgB(i - 1)) < 10 ^ -7
H = Sqr(X ^ 2 + Y ^ 2) / Cos(B(i)) - N
Br = B(i)
Ba = Txt(Br)
La = Txt(Lr)
TextDD(0).Text = Ba
TextDD(1).Text = La
TextDD(2).Text = Round(H, 3)
End Sub
'==========================================================
'参数赋值
Private Sub Form_Load()
PI = 3.14159265358979
'椭球参数赋值
XAa = 6378140: XAb = 6356755.28815753: XAc = 6399596.65198801: XAe2 = 0.006694384999588: XAe12 = 0.006739501819473
BJa = 6378245: BJb = 6356863.01877305: BJc = 6399698.90178271: BJe2 = 0.006693421622966: BJe12 = 0.006738525414683
WGSa = 6378137: WGSb = 6356752.3142: WGSc = 6399593.6258: WGSe2 = 0.0066943799013: WGSe12 = 0.00673949674227
End Sub
'==========================================================
'度数（&&&.&& && &&&&)转弧度函数
Function Rad(Txt As String) As Double
S = Val(Txt)
du = Fix(S)
fe = Fix((S - du) * 100)
mi = Round((S - du - fe * 0.01) * 10000, 4)
Rad = (du + fe / 60 + mi / 3600) * PI / 180
End Function
'弧度转度数（&&&.&& && &&&&）函数
Function Txt(ra) As Double
d = ra * 180 / PI
du = Fix(d)
fe = Fix((d - du) * 60)
mi = Round(((d - du) * 60 - fe) * 60, 4)
Txt = du + fe * 0.01 + mi * 0.0001
End Function
'==========================================================================
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -