两个邮政编码或地址之间的Ms访问距离的VBA代码

Question

我一直在尝试使用MS Access计算两个邮政编码之间的距离，我编写了以下代码：

Public Function GetDuration(start As String, dest As String)
    Dim firstVal As String, secondVal As String, lastVal As String
    firstVal = "http://maps.googleapis.com/maps/api/distancematrix/json?origins="
    secondVal = "&destinations="
    lastVal = "&mode=car&language=en&sensor=false"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(start, " ", "+") & secondVal & Replace(dest, " ", "+") & lastVal
    objHTTP.Open "GET", URL, False
    objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    objHTTP.send ("")
    If InStr(objHTTP.responseText, """duration"" : {") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = "duration(?:.|\n)*?""value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHTTP.responseText)
    Exit Function
ErrorHandl:
    GetDuration = -1
End Function

但它不能正常工作。有人可以帮我修复这段代码吗？

Answer 1

你的正则表达式不匹配你想要的数字 - http://regexr.com/3dfa8

请注意，我采用了谷歌地图API的JSON回复并将你的正则表达式应用于它 - 它不仅仅匹配你想要的数字。

我自己不是正则表达式的主人，因此我只需在生成的正则表达式匹配变量中执行子字符串（Access中的“mid”）。此外，您没有返回任何内容（您没有在代码结束之前将GetDuration设置为任何内容，除非它在ErrorHandl标记之后执行代码）。我会尝试这样的事情：

Set match = matches(0)
Set value_pattern = """value"" : "
GetDuration = Mid(matches, InStr(matches, value_pattern)+Len(value_pattern), Len(matches))

我没有测试，但我认为你将能够修复你的代码。

Answer 2

你可以设置一个表格看起来像这样。 。 。

然后，添加此脚本。

Option Compare Database

Private Sub Command0_Click()


Dim sXMLURL As String
Me.Text1.SetFocus
sXMLURL = "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & Me.Text1.Text & "&destinations="
Me.Text2.SetFocus
sXMLURL = sXMLURL & Me.Text2.Text & "&mode=driving&language=en-US&units=imperial&sensor=false"

Dim objXMLHTTP As MSXML2.ServerXMLHTTP60
Set objXMLHTTP = New MSXML2.ServerXMLHTTP60

With objXMLHTTP
    .Open "GET", sXMLURL, False
    .setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
    .send
End With

'Debug.Print objXMLHTTP.responseText

Dim domResponse As DOMDocument60
Set domResponse = New DOMDocument60
domResponse.loadXML objXMLHTTP.responseText
Dim ixnStatus
Set ixnStatus = domResponse.selectSingleNode("//status")

'Debug.Print ixnStatus.Text

If ixnStatus.Text = "OK" Then
    Dim ixnDistance, ixnDuration
    Set ixnDistance = domResponse.selectSingleNode("/DistanceMatrixResponse/row/element/distance/text")
    Set ixnDuration = domResponse.selectSingleNode("/DistanceMatrixResponse/row/element/duration/text")
    'Debug.Print "Distance: " & ixnDistance.Text
    'Debug.Print "Duration: " & ixnDuration.Text
    Me.Text3 = ixnDistance.Text
    Me.Text4 = ixnDuration.Text
End If

Me.Command0.SetFocus

Set domResponse = Nothing
Set objXMLHTTP = Nothing

End Sub

应该这样做。

Answer 3

从2018年7月开始，请参阅此论坛，了解有关Google商业模式更改的讨论。如果不创建Google帐户并创建API密钥，则上述代码无效。另请注意，Google距离矩阵的网址链接以https而非http开头。

https://www.access-programmers.co.uk/forums/showthread.php?t=225339&page=6

Private Sub cmdCalculate_Click()
    Dim strKey As String
    strKey = "AIzaSyAWSlNzPXIhnVwuGR6w9VigQJaSeXdplH4"

Dim sXMLURL As String
    Me.txtOrigin.SetFocus
    sXMLURL = "https://maps.googleapis.com/maps/api/distancematrix/xml? 
    origins=" & Me.txtOrigin.Text & "&destinations="
    Me.txtDest.SetFocus
    sXMLURL = sXMLURL & Me.txtDest.Text & "&mode=driving&language=en- 
    US&units=imperial&sensor=false"
    sXMLURL = sXMLURL & "&key=" & strKey

Dim objXMLHTTP As MSXML2.ServerXMLHTTP60
Set objXMLHTTP = New MSXML2.ServerXMLHTTP60

With objXMLHTTP
.Open "GET", sXMLURL, False
.setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
.send
End With

'Debug.Print objXMLHTTP.responseText

Dim domResponse As DOMDocument60
Set domResponse = New DOMDocument60
domResponse.loadXML objXMLHTTP.responseText
Dim ixnStatus
Set ixnStatus = domResponse.selectSingleNode("//status")

'Debug.Print ixnStatus.Text

If ixnStatus.Text = "OK" Then
Dim ixnDistance, ixnDuration
Set ixnDistance =domResponse.selectSingleNode("/DistanceMatrixResponse/row/element/distance/text")
    Set ixnDuration = domResponse.selectSingleNode("/DistanceMatrixResponse/row/element/duration/text")
'Debug.Print "Distance: " & ixnDistance.Text
'Debug.Print "Duration: " & ixnDuration.Text
Me.txtDistance = ixnDistance.Text
Me.txtDuration = ixnDuration.Text
End If

Me.cmdCalculate.SetFocus

Set domResponse = Nothing
Set objXMLHTTP = Nothing

End Sub