使用VBA直接从百度地图网站获取两地距离

majiechi

AA列是Q列出站到R列到站百度地图的距离，AC列是Q列出站到AB列参考城市百度地图的距离。
以上都是百度地图驾车推荐线路，可以的话，麻烦同事多弄一份代码，是百度地图最短线路。求VBA大神帮忙，谢谢

2E-er

http://club.excelhome.net/thread-1163384-1-1.html

majiechi

2E-er 发表于 2020-1-15 22:13
http://club.excelhome.net/thread-1163384-1-1.html

那个帖子是固定两个城市之间的距离，我需要的是我自己输入两个城市

majiechi

2E-er 发表于 2020-1-15 22:13
http://club.excelhome.net/thread-1163384-1-1.html

这个不是我需要的两个城市的距离，代码里已经固定了两个城市了

2E-er

majiechi 发表于 2020-1-16 08:42
这个不是我需要的两个城市的距离，代码里已经固定了两个城市了

majiechi

2E-er 发表于 2020-1-16 13:16

Sub 里程查询()
k = [a65535].End(xlUp).Row
For i = 2 To k
CityFrom = Cells(i, "q")
CityTo = Cells(i, "r")
Dim strText As String
Dim URL As String
Dim dis, mtime

URL = "http://map.baidu.com/?"
URL = URL & "qt=nav"
URL = URL & "&c=223"
URL = URL & "&sn=2$$$$$$" & CityFrom & "$$0$$$$"
URL = URL & "&en=2$$$$$$" & CityTo & "$$0$$$$"

With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
strText = .responsetext
dis = Val(Split(strText, """dis"":")(1))
mtime = Val(Mid(strText, InStrRev(strText, """time"":") + 7))
Cells(i, "aa") = dis / 1000

End With
Next
End Sub
这个是根据网站一些大神参考出来的，但是，我要q列到r列的距离，同事我还要q列到ab列的距离，另外这个代码只能得到部分距离，并没有得到全部的距离。

majiechi

用下面的代码不是所有城市距离都有的，有一些没有的，搞不懂啊，有没有大神解释一下什么回事啊？

Sub 里程查询()
k = [a65535].End(xlUp).Row
For i = 2 To k
CityFrom = Cells(i, "q")
CityTo = Cells(i, "r")
Dim strText As String
Dim URL As String
Dim dis, mtime

URL = "http://map.baidu.com/?"
URL = URL & "qt=nav"
URL = URL & "&c=223"
URL = URL & "&sn=2$$$$$$" & CityFrom & "$$0$$$$"
URL = URL & "&en=2$$$$$$" & CityTo & "$$0$$$$"

With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
strText = .responsetext
dis = Val(Split(strText, """dis"":")(1))
mtime = Val(Mid(strText, InStrRev(strText, """time"":") + 7))
Cells(i, "aa") = dis / 1000

End With
Next
End Sub

fgjg1105

majiechi 发表于 2020-1-16 17:02
用下面的代码不是所有城市距离都有的，有一些没有的，搞不懂啊，有没有大神解释一下什么回事啊？

Sub 里 ...

XMLHttp的方式有问题，要换成WinHttp.WinHttpRequest.5.1
用下面代码可以正常使用：

1. Sub 里程查询百度版()
   
2. k = [a65535].End(xlUp).Row
   
3. Application.ScreenUpdating = False
   
4. For i = 2 To k
   
5. Dim CityFrom As String
   
6. Dim CityTo As String
   
7. CityFrom = Cells(i, 1)
   
8. CityTo = Cells(i, 2)
   
9. Dim strText As String
   
10. Dim URL As String
    
11. Dim dis, mtime, test
    
12. Dim strJS As String
    
13. With CreateObject("WinHttp.WinHttpRequest.5.1")
    
14.      URL = "http://map.baidu.com/?"
    
15.      URL = URL & "newmap=1&reqflag=pcmap&biz=1&qt=nav"
    
16.      URL = URL & "&c=1"
    
17.      URL = URL & "&sn=2$$$$$$" & CityFrom & "$$0$$$$"
    
18.      URL = URL & "&en=2$$$$$$" & CityTo & "$$0$$$$"
    
19.      .Open "GET", URL, False
    
20.      .send
    
21.         '等待响应
    
22.         Do While .WaitForResponse <> True
    
23.         DoEvents
    
24.         Loop
    
25.         strText = .responseText
    
26. 
    
27.     dis = Val(Split(strText, """dis"":")(1))
    
28.     'mtime = Val(Mid(strText, InStrRev(strText, """time"":") + 7))
    
29.     'MsgBox "约" & Format(dis / 1000, "0.00公里/") & Format(mtime / 86400, "hh小时nn分钟")
    
30.     Cells(i, 3) = dis / 1000
    
31. End With
    
32. Next
    
33. Application.DisplayStatusBar = True
    
34. End Sub
    

复制代码

fgjg1105

XMLHttp的方式有问题，要换成WinHttp.WinHttpRequest.5.1
用下面代码可以正常使用：

Sub 里程查询百度版()
k = [a65535].End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To k
Dim CityFrom As String
Dim CityTo As String
CityFrom = Cells(i, 1)
CityTo = Cells(i, 2)
Dim strText As String
Dim URL As String
Dim dis, mtime, test
Dim strJS As String
With CreateObject("WinHttp.WinHttpRequest.5.1")
     URL = "http://map.baidu.com/?"
     URL = URL & "newmap=1&reqflag=pcmap&biz=1&qt=nav"
     URL = URL & "&c=1"
     URL = URL & "&sn=2$$$$$$" & CityFrom & "$$0$$$$"
     URL = URL & "&en=2$$$$$$" & CityTo & "$$0$$$$"
     .Open "GET", URL, False
     .send
        '等待响应
        Do While .WaitForResponse <> True
        DoEvents
        Loop
        strText = .responseText

    dis = Val(Split(strText, """dis"":")(1))
    'mtime = Val(Mid(strText, InStrRev(strText, """time"":") + 7))
    'MsgBox "约" & Format(dis / 1000, "0.00公里/") & Format(mtime / 86400, "hh小时nn分钟")
    Cells(i, 3) = dis / 1000
End With
Next
Application.DisplayStatusBar = True
End Sub

fgjg1105

XMLHttp的方式有问题，要换成WinHttp.WinHttpRequest.5.1

用下面代码可以正常使用：
Sub 里程查询百度版()
k = [a65535].End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To k
Dim CityFrom As String
Dim CityTo As String
CityFrom = Cells(i, 1)
CityTo = Cells(i, 2)
Dim strText As String
Dim URL As String
Dim dis, mtime, test
Dim strJS As String
With CreateObject("WinHttp.WinHttpRequest.5.1")
     URL = "http://map.baidu.com/?"
     URL = URL & "newmap=1&reqflag=pcmap&biz=1&qt=nav"
     URL = URL & "&c=1"
     URL = URL & "&sn=2$$$$$$" & CityFrom & "$$0$$$$"
     URL = URL & "&en=2$$$$$$" & CityTo & "$$0$$$$"
     .Open "GET", URL, False
     .send
        '等待响应
        Do While .WaitForResponse <> True
        DoEvents
        Loop
        strText = .responseText

    dis = Val(Split(strText, """dis"":")(1))
    'mtime = Val(Mid(strText, InStrRev(strText, """time"":") + 7))
    'MsgBox "约" & Format(dis / 1000, "0.00公里/") & Format(mtime / 86400, "hh小时nn分钟")
    Cells(i, 3) = dis / 1000
End With
Next
Application.DisplayStatusBar = True
End Sub