地形图分幅与编号程序（VB）

徐州师范大学测绘学院  俞礼彬

基于数字测图原理与方法，本程序主要有两个模块组成，即由经纬度推算图幅编号，或由图幅编号推算经纬度，程序界面及运行情况如下所示：

http://s5/middle/63a7c6abna231432c9b14&690

运行结果：
http://s6/middle/63a7c6abna231432fc975&690
程序代码（VB）：

Private Sub Command1_Click()
Dim j1 As Integer, j2 As Integer, j3 As Double, j As Double
Dim w1 As Integer, w2 As Integer, w3 As Double, w As Double
Dim a As Integer, astr As String
Dim b As Integer, bstr As String
Dim bili As String, daima As String, dj As Double, dw As Double
Dim cmod As Double, dmod As Double
Dim c As Integer, d As Integer, dx As Double
If Text1(0) = "" Or Text1(1) = "" Or Text1(2) = "" Then
    MsgBox "请输入经度相关数据！", vbExclamation, "警告"
    Exit Sub
End If
If Text2(0) = "" Or Text2(1) = "" Or Text2(2) = "" Then
    MsgBox "请输入纬度相关数据！", vbExclamation, "警告"
    Exit Sub
End If
j1 = Val(Text1(0).Text): j2 = Val(Text1(1).Text): j3 = Val(Text1(2).Text)
w1 = Val(Text2(0).Text): w2 = Val(Text2(1).Text): w3 = Val(Text2(2).Text)
j = j1 + j2 / 60 + j3 / 3600
w = w1 + w2 / 60 + w3 / 3600
If j > 180 Or j < 0 Then
    MsgBox "经度不符合要求！", vbExclamation, "警告"
    Exit Sub
End If
If w > 90 Or w < 0 Then
    MsgBox "纬度不符合要求！", vbExclamation, "警告"
    Exit Sub
End If
a = Int(w1 / 4) + 1
b = Int(j1 / 6) + 31
astr = Chr(64 + a)
bstr = CStr(b)
Text3 = astr
Text4 = bstr
bili = Combo1.List(Combo1.ListIndex)
If bili = "" Then
    MsgBox "请选择比例尺！", vbExclamation, "警告"
    Exit Sub
End If
If bili = "1：100万" Then
    Label5.Visible = False
    Label6.Visible = False
    Label7.Visible = False
    Text5.Visible = False
    Text6.Visible = False
    Text7.Visible = False
    Text8 = astr + bstr
    Exit Sub
ElseIf bili = "1：50万" Then
    daima = "B"
    dj = 3
    dw = 2
ElseIf bili = "1：25万" Then
    daima = "C"
    dj = 1.3
    dw = 1
ElseIf bili = "1：10万" Then
    daima = "D"
    dj = 0.3
    dw = 0.2
ElseIf bili = "1：5万" Then
    daima = "E"
    dj = 0.15
    dw = 0.1
ElseIf bili = "1：2.5万" Then
    daima = "F"
    dj = 0.073
    dw = 0.05
ElseIf bili = "1：1万" Then
    daima = "G"
    dj = 0.0345
    dw = 0.023
ElseIf bili = "1：5000" Then
    daima = "H"
    dj = 0.01525
    dw = 0.0115
End If
cmod = (w / 4 - Int(w / 4)) * 4
dmod = (j / 6 - Int(j / 6)) * 6
cmod = cmod * 3600
dmod = dmod * 3600
c = 4 * 3600 / switch(dw) - (cmod switch(dw))
d = dmod switch(dj) + 1
Text5 = Format(c, "000")
Text6 = Format(d, "000")
Text7 = daima
Text8 = astr + bstr + daima + Format(c, "000") + Format(d, "000")
End Sub

Private Sub Command2_Click()
Dim bianhao As String
Dim astr As String, bstr As String
Dim a As Integer, b As Integer, jint As Integer, wint As Integer
Dim c As Integer, d As Integer, daima As String, bili As String
Dim dj As Double, dw As Double
Dim jnum As Double, wnum As Double
Dim j1 As Integer, j2 As Integer, j3 As Double
Dim w1 As Integer, w2 As Integer, w3 As Double
bianhao = Text9.Text
astr = Left(bianhao, 1)
bstr = Mid(bianhao, 2, 2)
If Asc(astr) > 86 Or Asc(astr) < 65 Then
    MsgBox "地形图图号不准确，请重新输入！", vbExclamation, "警告"
    Exit Sub
End If
If Val(bstr) < 31 Then
    MsgBox "地形图图号不准确，请重新输入！", vbExclamation, "警告"
    Exit Sub
End If
a = Asc(astr) - 64
b = Val(bstr)
daima = Mid(bianhao, 4, 1)
If Asc(daima) > 72 Or Asc(daima) < 65 Then
    MsgBox "地形图图号不准确，请重新输入！", vbExclamation, "警告"
    Exit Sub
End If
wint = (a - 1) * 4
jint = (b - 31) * 6
If daima = "A" Then
    bili = "1：100万"
    Text10(0).Text = jint
    Text11(0).Text = wint
    Text12.Text = bili
    Exit Sub
ElseIf daima = "B" Then
    bili = "1：50万"
    dj = 3
    dw = 2
ElseIf daima = "C" Then
    bili = "1：25万"
    dj = 1.3
    dw = 1
ElseIf daima = "D" Then
    bili = "1：10万"
    dj = 0.3
    dw = 0.2
ElseIf daima = "E" Then
    bili = "1：5万"
    dj = 0.15
    dw = 0.1
ElseIf daima = "F" Then
    bili = "1：2.5万"
    dj = 0.073
    dw = 0.05
ElseIf daima = "G" Then
    bili = "1：1万"
    dj = 0.0345
    dw = 0.023
ElseIf daima = "H" Then
    bili = "1：5000"
    dj = 0.01525
    dw = 0.0115
End If
c = Mid(bianhao, 5, 3)
d = Right(bianhao, 3)
wnum = (4 * 3600 / switch(dw) - c) * switch(dw)
Call miaodu(wnum, w1, w2, w3)
Text11(0).Text = wint + w1
Text11(1).Text = w2
Text11(2).Text = Format(w3, "0.0")
jnum = (d - 1) * switch(dj)
Call miaodu(jnum, j1, j2, j3)
Text10(0).Text = jint + j1
Text10(1).Text = j2
Text10(2).Text = Format(j3, "0.0")
Text12.Text = bili
End Sub

Private Sub Form_Load()
For i = 1 To 2
    Load Text1(i)
    Load Text2(i)
    Load Text10(i)
    Load Text11(i)
    Text1(i).Left = Text1(i - 1).Left + Text1(i - 1).Width
    Text1(i).Top = Text1(i - 1).Top
    Text1(i).Visible = True
    Text2(i).Left = Text2(i - 1).Left + Text2(i - 1).Width
    Text2(i).Top = Text2(i - 1).Top
    Text2(i).Visible = True
    Text10(i).Left = Text10(i - 1).Left + Text10(i - 1).Width
    Text10(i).Top = Text10(i - 1).Top
    Text10(i).Visible = True
    Text11(i).Left = Text11(i - 1).Left + Text11(i - 1).Width
    Text11(i).Top = Text11(i - 1).Top
    Text11(i).Visible = True
Next i
End Sub

Private Function switch(ByVal x As Double) As Double
Dim a As Integer, b As Integer, c As Double
a = Fix(x)
b = Fix((x - a) * 100)
c = ((x - a) * 100 - b) * 100
switch = a * 3600 + b * 60 + c
End Function

Private Sub miaodu(x As Double, a As Integer, b As Integer, c As Double)
a = x 3600
b = (x - a * 3600) 60
c = x - a * 3600 - b * 60
End Sub