📄 图幅面积.frm
字号:
BeginProperty Font
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 336
Left = 5860
TabIndex = 12
Top = 1608
Width = 1800
End
Begin VB.Label Label3
Alignment = 1 'Right Justify
BackColor = &H00FFFFFF&
BorderStyle = 1 'Fixed Single
BeginProperty Font
Name = "宋体"
Size = 10.8
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 336
Left = 5860
TabIndex = 10
Top = 1056
Width = 1800
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "球面面积(亩)"
Height = 180
Left = 4700
TabIndex = 9
Top = 1700
Width = 1092
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "平面面积(M"
Height = 180
Left = 4720
TabIndex = 8
Top = 1164
Width = 912
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public T1 As Integer, T2 As Integer
Private Sub Check1_Click()
If Command1.Caption = "计 算" Then
Command1.Caption = "计算/保存"
Else
Command1.Caption = "计 算"
End If
End Sub
Private Sub Command1_Click()
Dim B As Double, L As Double, DB As Double, PM As Double, QM As Double, L0 As Double, PMM As Double
Dim P() As Double, I As Integer, NI As Integer, DT As String, DS As String, BT As Double, LT As Double
Dim FD As String, QMM As Double
If T1 * T2 = 0 Then '程序首次启动后text1和text2未发生变化
Exit Sub
End If
BT = Val(Text1.Text) '存盘用
LT = Val(Text2.Text) '存盘用
B = DEG(Text1.Text)
L = DEG(Text2.Text)
If Option6 = True Then
L0 = L - Int((L + 1.5) / 3) * 3 '与中央子午线经差
Else
L0 = L - (Int(L / 6) * 6 + 3) '与中央子午线经差
End If
If Option1.Value = True Then '一万图
ReDim P(1 To D1 * 4 + 1, 1 To 2) As Double '一万图4个图廓点
'PXY()-计算图廓点坐标数组.参数表:(左下角纬度,左下角经度[与中央子午线经差],纬差,经差,纵向或横向的一万图幅数[用于加密图廓点],
'返回值[图廓点坐标数组P(X,Y)]从左下角起顺时针沿图廓回至起点) [角度为十进制度]
Call PXY(B, L0, DB1, DL1, D1, P()) '计算图廓点坐标
PM = PMJ(D1, P()) 'PMJ()-计算面积.参数表:(纵向或横向的一万图幅数数,图廓点坐标数组P[X,Y])
PM = Int((Int(PM * 100) + 5) / 10) / 10
Label3.Caption = Str(PM)
PMM = PM * 3 / 2000 '换算为亩
PMM = Int((Int(PMM * 1000) + 5) / 10) / 100
Label7.Caption = Str(PMM)
QM = QMJ(B, B + DB1, DL1) '计算曲面面积.参数表:(左下角纬度,左上角纬度,经差) [角度为十进制度]
QM = Int((Int(QM * 100) + 5) / 10) / 10
Label11.Caption = Str(QM)
QMM = QM * 3 / 2000 '换算为亩
QMM = Int((Int(QMM * 1000) + 5) / 10) / 100
Label4.Caption = Str(QMM)
ElseIf Option2.Value = True Then '二万五图
ReDim P(1 To D25 * 4 + 1, 1 To 2) As Double
Call PXY(B, L0, DB25, DL25, D25, P()) '计算图廓点坐标
PM = PMJ(D25, P()) 'PMJ()-计算面积.参数表:(纵向或横向的一万图幅数数,图廓点坐标数组P[X,Y])
PM = Int((Int(PM * 100) + 5) / 10) / 10
Label3.Caption = Str(PM)
PMM = PM * 3 / 2000 '换算为亩
PMM = Int((Int(PMM * 1000) + 5) / 10) / 100
Label7.Caption = Str(PMM)
QM = QMJ(B, B + DB25, DL25) '计算曲面面积.参数表:(左下角纬度,左上角纬度,经差) [角度为十进制度]
QM = Int((Int(QM * 100) + 5) / 10) / 10
Label11.Caption = Str(QM)
QMM = QM * 3 / 2000 '换算为亩
QMM = Int((Int(QMM * 1000) + 5) / 10) / 100
Label4.Caption = Str(QMM)
ElseIf Option3.Value = True Then '五万图
ReDim P(1 To D5 * 4 + 1, 1 To 2) As Double
Call PXY(B, L0, DB5, DL5, D5, P()) '计算图廓点坐标
PM = PMJ(D5, P()) 'PMJ()-计算面积.参数表:(纵向或横向的一万图幅数数,图廓点坐标数组P[X,Y])
PM = Int((Int(PM * 100) + 5) / 10) / 10
Label3.Caption = Str(PM)
PMM = PM * 3 / 2000 '换算为亩
PMM = Int((Int(PMM * 1000) + 5) / 10) / 100
Label7.Caption = Str(PMM)
QM = QMJ(B, B + DB5, DL5) '计算曲面面积.参数表:(左下角纬度,左上角纬度,经差) [角度为十进制度]
QM = Int((Int(QM * 100) + 5) / 10) / 10
Label11.Caption = Str(QM)
QMM = QM * 3 / 2000 '换算为亩
QMM = Int((Int(QMM * 1000) + 5) / 10) / 100
Label4.Caption = Str(QMM)
Else '十万图
ReDim P(1 To D10 * 4 + 1, 1 To 2) As Double
Call PXY(B, L0, DB10, DL10, D10, P()) '计算图廓点坐标
PM = PMJ(D10, P()) 'PMJ()-计算面积.参数表:(纵向或横向的一万图幅数数,图廓点坐标数组P[X,Y])
PM = Int((Int(PM * 100) + 5) / 10) / 10
Label3.Caption = Str(PM)
PMM = PM * 3 / 2000 '换算为亩
PMM = Int((Int(PMM * 1000) + 5) / 10) / 100
Label7.Caption = Str(PMM)
QM = QMJ(B, B + DB10, DL10) '计算曲面面积.参数表:(左下角纬度,左上角纬度,经差) [角度为十进制度]
QM = Int((Int(QM * 100) + 5) / 10) / 10
Label11.Caption = Str(QM)
QMM = QM * 3 / 2000 '换算为亩
QMM = Int((Int(QMM * 1000) + 5) / 10) / 100
Label4.Caption = Str(QMM)
End If
If Check1.Value = 1 Then
DT = Date + Time
CommonDialog1.ShowSave
If CommonDialog1.FileName <> "" Then
Open CommonDialog1.FileName For Append As #1
If Option1.Value = True Then
NI = D1
DS = "比例尺:1万"
ElseIf Option2.Value = True Then
NI = D25
DS = "比例尺:2.5万"
ElseIf Option3.Value = True Then
NI = D5
DS = "比例尺:5万"
Else
NI = D10
DS = "比例尺:10万"
End If
If Option6.Value = True Then
FD = " 3度带"
Else
FD = " 6度带"
End If
Write #1,
Write #1, DT
Write #1, DS + FD
Write #1, "左下角经纬度", BT, LT
Write #1, "平面面积(平方米,亩)", PM, PMM
Write #1, "曲面面积(平方米,亩)", QM, QMM
For I = 1 To NI * 4
Write #1, P(I, 1), P(I, 2)
Next I
Close #1
End If
End If
End Sub
Private Sub Command2_Click()
Unload Form1
End Sub
Private Sub Form_Load()
Command1.Caption = "计 算"
Option1.Value = True
Option6.Value = True
Check1.Value = 0
T1 = 0
T2 = 0
End Sub
Private Sub Option1_Click()
Option6.Value = True
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Option2_Click()
Option5.Value = True
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Option3_Click()
Option5.Value = True
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Option4_Click()
Option5.Value = True
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Option5_Click()
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Option6_Click()
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Text1_Change()
T1 = 1
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Text1_LostFocus()
Dim MI As Integer
Text1.Text = Str(Val(Text1.Text))
If Val(Text1.Text) < 0 Or Val(Text1.Text) >= 90 Then
MI = MsgBox("纬度应在0~90之间!", 16, "出错提示")
Text1.SetFocus
End If
End Sub
Private Sub Text2_Change()
T2 = 1
Label7.Caption = ""
Label3.Caption = ""
Label4.Caption = ""
Label11.Caption = ""
End Sub
Private Sub Text2_LostFocus()
Dim MI As Integer
Text2.Text = Str(Val(Text2.Text))
If Val(Text2.Text) < 0 Or Val(Text2.Text) >= 360 Then
MI = MsgBox("经度应在0~360之间!", 16, "出错提示")
Text2.SetFocus
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -