求助GPS经纬度与百度经纬度的转换方法。

abccba_ln · 发表于 2018-8-10 16:13

'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
'--------------------------------------坐标转换----------------------------------
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
Public Const pi As Double = 3.14159265358979
Public Const a As Double = 6378245#
Public Const ee As Double = 6.69342162296594E-03
Public Const X_pi As Double = 3.14159265358979 * 3000# / 180#
Function wgs2bd(lat, lon)
wgs2gcj = wgs2gcj(lat, lon)
gcj2bd = gcj2bd(wgs2gcj(0), wgs2gcj(1))
End Function
Function gcj2bd(lat, lon)
x = lon: y = lat
Z = Sqr(x * x + y * y) + 0.00002 * Sin(y * X_pi)
theta = Application.Atan2(y, x) + 0.000003 * Cos(x * X_pi)
bd_lon = Z * Cos(theta) + 0.00644 '***?
bd_lat = Z * Sin(theta) + 0.00633 '***?
' bd_lon = Z * Cos(theta) + 0.0065
' bd_lat = Z * Sin(theta) + 0.006
gcj2bd = bd_lat & "," & bd_lon
End Function
Function bd2gcj(lat, lon)
x = lon - 0.0065: y = lat - 0.006
Z = Sqr(x * x + y * y) - 0.00002 * Sin(y * X_pi) '***
theta = Application.Atan2(y, x) - 0.000003 * Cos(x * X_pi)
gg_lon = Z * Cos(theta)
gg_lat = Z * Sin(theta)
bd2gcj = gg_lat & "," & gg_lon
End Function
Function wgs2gcj(lat, lon)
dLat = transformLat(lon - 105#, lat - 35#)
dLon = transformLon(lon - 105#, lat - 35#)
radLat = lat / 180# * pi
magic = Sin(radLat)
magic = 1 - ee * magic * magic
sqrtMagic = Sqr(magic) '***
dLat = (dLat * 180#) / ((a * (1 - ee)) / (magic * sqrtMagic) * pi)
dLon = (dLon * 180#) / (a / sqrtMagic * Cos(radLat) * pi)
mgLat = lat + dLat
mgLon = lon + dLon
wgs2gcj = mgLat & "," & mgLon ' Loc
End Function
Function transformLat(lat, lon)
ret = -100# + 2# * lat + 3# * lon + 0.2 * lon * lon + 0.1 * lat * lon + 0.2 * Sqr(Abs(lat))
ret = ret + (20# * Sin(6# * lat * pi) + 20# * Sin(2# * lat * pi)) * 2# / 3#
ret = ret + (20# * Sin(lon * pi) + 40# * Sin(lon / 3# * pi)) * 2# / 3#
ret = ret + (160# * Sin(lon / 12# * pi) + 320 * Sin(lon * pi / 30#)) * 2# / 3#
transformLat = ret
End Function
Function transformLon(lat, lon)
ret = 300# + lat + 2# * lon + 0.1 * lat * lat + 0.1 * lat * lon + 0.1 * Sqr(Abs(lat))
ret = ret + (20# * Sin(6# * lat * pi) + 20# * Sin(2# * lat * pi)) * 2# / 3#
ret = ret + (20# * Sin(lat * pi) + 40# * Sin(lat / 3# * pi)) * 2# / 3#
ret = ret + (150# * Sin(lat / 12# * pi) + 300# * Sin(lat / 30# * pi)) * 2# / 3#
transformLon = ret
End Function
Function Base64Decode(strEncoded) As String
On Error Resume Next
Dim arrB() As Byte, bTmp(3) As Byte, bT As Long, bRet() As Byte
Dim I As Long, j As Long
arrB = StrConv(strEncoded, vbFromUnicode)
j = InStr(strEncoded & "=", "=") - 2
ReDim bRet(j - j \ 4 - 1)
For I = 0 To j Step 4
Erase bTmp
bTmp(0) = (InStr(cstBase64, Chr(arrB(I))) - 1) And 63
bTmp(1) = (InStr(cstBase64, Chr(arrB(I + 1))) - 1) And 63
bTmp(2) = (InStr(cstBase64, Chr(arrB(I + 2))) - 1) And 63
bTmp(3) = (InStr(cstBase64, Chr(arrB(I + 3))) - 1) And 63
bT = bTmp(0) * 2 ^ 18 + bTmp(1) * 2 ^ 12 + bTmp(2) * 2 ^ 6 + bTmp(3)
bRet((I \ 4) * 3) = bT \ 65536
bRet((I \ 4) * 3 + 1) = (bT And 65280) \ 256
bRet((I \ 4) * 3 + 2) = bT And 255
Next
Base64Decode = StrConv(bRet, vbUnicode)
End Function
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
'--------------------------------------坐标转换结束----------------------------------
'---------------------------------------------------------------------------------------

复制代码

论坛上大神给的自定义函数，记不住哪个帖子了，实测好用。

zilong8045 · 发表于 2018-8-10 16:27

牛人真多 vb源码伺候了

cuiyuguo9 · 发表于 2018-8-20 10:55

不会用啊，能做成表格吗

YZC51 · 发表于 2018-8-20 15:15

应该这样
Function wgs2bd(lat, lon)
wgs2gcj1 = wgs2gcj(lat, lon)
gcj2bd1 = gcj2bd(Split(wgs2gcj1, ",")(0), Split(wgs2gcj1, ",")(1))
wgs2bd = gcj2bd1
End Function

abccba_ln · 发表于 2018-8-20 16:41

C列是用的自定义函数公式，D、E列是将C列内容数值粘贴到D列后，再分列得到。

zopey · 发表于 2018-8-20 16:48

YZC51 发表于 2018-8-20 15:15
应该这样
Function wgs2bd(lat, lon)
wgs2gcj1 = wgs2gcj(lat, lon)

加密算法不可能这么简单破解。

YZC51 · 发表于 2018-8-20 19:20

zopey 发表于 2018-8-20 16:48
加密算法不可能这么简单破解。

请老师指教，这样可以不？
Dim strText As String
Dim gpspoi As String
URL = "http://api.map.baidu.com/ag/coord/convert?from=0&to=4&x=" & lng & "&y=" & lat
With CreateObject("MSXML2.XMLHTTP")
      .Open "GET", URL, False
      .Send
      strText = .responsetext
End With
'百度数据返回分析并赋值和解码
If x Then
      GPS2BD = Base64Decode(Split(strText, """")(5))
Else
      GPS2BD = Base64Decode(Split(strText, """")(9))
End If
End Function

'VBA Base64 解码/解密函数：
Function Base64Decode(B64) As String                                  'Base64 解码
On Error GoTo over                                                       '排错
Dim OutStr() As Byte, i As Long, j As Long
Const B64_CHAR_DICT = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
If InStr(1, B64, "=") <> 0 Then B64 = Left(B64, InStr(1, B64, "=") - 1)    '判断Base64真实长度,除去补位
Dim kk, length As Long, mods As Long
mods = Len(B64) Mod 4
length = Len(B64) - mods
ReDim OutStr(length / 4 * 3 - 1 + Switch(mods = 0, 0, mods = 2, 1, mods = 3, 2))
For i = 1 To length Step 4
      Dim buf(3) As Byte
      For j = 0 To 3
         buf(j) = InStr(1, B64_CHAR_DICT, Mid(B64, i + j, 1)) - 1          '根据字符的位置取得索引值
      Next
      OutStr((i - 1) / 4 * 3) = buf(0) * &H4 + (buf(1) And &H30) / &H10
      OutStr((i - 1) / 4 * 3 + 1) = (buf(1) And &HF) * &H10 + (buf(2) And &H3C) / &H4
      OutStr((i - 1) / 4 * 3 + 2) = (buf(2) And &H3) * &H40 + buf(3)
Next
If mods = 2 Then
      OutStr(length / 4 * 3) = (InStr(1, B64_CHAR_DICT, Mid(B64, length + 1, 1)) - 1) * &H4 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &H30) / 16
ElseIf mods = 3 Then
      OutStr(length / 4 * 3) = (InStr(1, B64_CHAR_DICT, Mid(B64, length + 1, 1)) - 1) * &H4 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &H30) / 16
      OutStr(length / 4 * 3 + 1) = ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 2, 1)) - 1) And &HF) * &H10 + ((InStr(1, B64_CHAR_DICT, Mid(B64, length + 3, 1)) - 1) And &H3C) / &H4
End If
For i = 0 To UBound(OutStr)
      Base64Decode = Base64Decode & Chr(OutStr(i))
Next i                                                    '读取解码结果
over:
End Function

YZC51 · 发表于 2018-8-20 19:26

代码审核中，先上附件

经纬度实例.rar (79.97 KB, 下载次数: 82)

zopey · 发表于 2018-8-21 17:24

YZC51 发表于 2018-8-20 19:26
代码审核中，先上附件

经调试，发现函数 application.atan2() 有严重误差，替换如下

Public Function Atan2(ByVal y As Double, ByVal x As Double) As Double
  Const PI As Double = 3.1415926535
If y > 0 Then
   If x >= y Then
   Atan2 = Atn(y / x)
   ElseIf x <= -y Then
   Atan2 = Atn(y / x) + PI
   Else
   Atan2 = PI / 2 - Atn(x / y)
   End If
Else
   If x >= -y Then
   Atan2 = Atn(y / x)
   ElseIf x <= y Then
   Atan2 = Atn(y / x) - PI
   Else
   Atan2 = -Atn(x / y) - PI / 2
   End If
End If
End Function

百度坐标转换.zip (27.02 KB, 下载次数: 130)

zopey · 发表于 2018-8-21 17:32

在替换atan2 函数后，代码调试对比结果如下图
1、wgs2gcj 、gcj2bd 函数转换结果与网页转换结果 gps2bd 基本一致
2、gcj2bd 与 bd2gcj 互相转换结果基本相同。

		自动登录	找回密码
密码			免费注册

[求助] 求助GPS经纬度与百度经纬度的转换方法。

评分

评分

评分

最新热点 /1