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

Question

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

Set olFldr = oNs.GetSharedDefaultFolder(objOwner, olFolderCalendar).Folders("Holiday Calendar")

但它无法正常工作。有人可以帮我解决这个问题吗？

Answer 1

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

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

我自己不是正则表达式的主人，因此我只需在生成的正则表达式匹配变量中执行子字符串（＆＃34; mid＆＃34;在Access中）。此外，您没有返回任何内容（您没有在代码结束之前将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密钥，以上代码将无法使用。另外，请注意，谷歌距离矩阵的url链接以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