【源代码分享】计算图幅号

Private Function GetSheetNumber(Lat As Double, Lon As Double, ScaleCode As String) As String
  Dim a As Integer, b As Integer, c As Integer, d As Integer
  Dim dB As Double, dL As Double
  Lat = Lat * 3600: Lon = Lon * 3600
  a = Fix(Lat / (4 * 3600)) + 1
  b = Fix(Lon / (6 * 3600)) + 31
  Select Case UCase(ScaleCode)
    Case "A": dB = 4 * 3600: dL = 6 * 3600
    Case "B": dB = 2 * 3600: dL = 3 * 3600
    Case "C": dB = 1 * 3600: dL = 1.5 * 3600
    Case "D": dB = 20 * 60: dL = 30 * 60
    Case "E": dB = 10 * 60: dL = 15 * 60
    Case "F": dB = 5 * 60: dL = 7.5 * 60
    Case "G": dB = 2.5 * 60: dL = 3.75 * 60
    Case "H": dB = 1.25 * 60: dL = 1.875 * 60
    Case Else: GetSheetNumber = "": Exit Function
  End Select
  c = 4 * 3600 / dB - Fix((Lat - Fix(Lat / (4 * 3600)) * 4 * 3600) / dB)
  d = Fix((Lon - Fix(Lon / (6 * 3600)) * 6 * 3600) / dL) + 1
  GetSheetNumber = Chr(64 + a) & Format(b, "00")
  If UCase(ScaleCode) <> "A" Then
     GetSheetNumber = GetSheetNumber & UCase(ScaleCode) & Format(c, "000") & Format(d, "000")
  End If
End Function
Private Function GetMapEageSw(SheetNumber As String) As String
  Dim a As Integer, b As Integer, c As Integer, d As Integer
  Dim ScaleCode As String
  Dim dB As Double, dL As Double
  Dim Lat As Double, Lon As Double
  SheetNumber = UCase(Trim(SheetNumber))
  If Len(SheetNumber) <> 10 And Len(SheetNumber) <> 3 Then GetMapEageSw = "": Exit Function
  a = Asc(Left(SheetNumber, 1))
  If a < 65 Or a > 86 Then GetMapEageSw = "": Exit Function
  b = CInt(Mid(SheetNumber, 2, 2))
  If b <= 0 Or b > 60 Then GetMapEageSw = "": Exit Function
  If Len(SheetNumber) <> 3 Then
     Select Case Mid(SheetNumber, 4, 1)
        Case "A": dB = 4: dL = 6
        Case "B": dB = 2: dL = 3
        Case "C": dB = 1: dL = 1.5
        Case "D": dB = 20 / 60: dL = 30 / 60
        Case "E": dB = 10 / 60: dL = 15 / 60
        Case "F": dB = 5 / 60: dL = 7.5 / 60
        Case "G": dB = 2.5 / 60: dL = 3.75 / 60
        Case "H": dB = 1.25 / 60: dL = 1.875 / 60
        Case Else: GetMapEageSw = "": Exit Function
      End Select
     c = CInt(Mid(SheetNumber, 5, 3))
     d = CInt(Mid(SheetNumber, 8, 3))
  Else
     dB = 4: dL = 6
     c = 0: d = 0
  End If
  Lon = (b - 31) * 6 + (d - 1) * dL
  Lat = (a - 64 - 1) * 4 + (4 / dB - c) * dB
  GetMapEageSw = Lat & "," & Lon
End Function
Sub Main()
   MsgBox GetSheetNumber(39 + 22 / 60 + 30 / 3600, 114 + 33 / 60 + 45 / 3600, "A")
   MsgBox GetMapEageSw("j50d002002")
End Sub