当前版块:问答社区 > 综合讨论区

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

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 

全部评论

等级:LV30
积分:38427
KAIGE 2019-12-07 16:26
请问可以用嘛?
回复 0
等级:LV30
积分:38824
hkai2658 2019-12-07 16:35
可以发一个给我
回复 0
等级:LV30
积分:9090
ynyanbin08 2019-12-12 10:34
这个有用!~!~mark了!~!~
回复 0
1
提交
悬赏回复规则
1、悬赏期为24小时,从发布时间起算;
2、悬赏期内提问者如设置评论为“精选评论”,视为悬赏结束,该精选评论人将获得本题全部悬赏积分;
3、悬赏期内如提问者未设置“精选评论”,则前5位评论者平分悬赏积分(如仅有一位评论,该评论者获得50%悬赏积分);
4、悬赏积分会自动发放到生态圈账户中,请留意站内信通知。
知道了

距离打开宝箱还剩7

是否花费200积分补签?
确认
取消