[Resolvido]Gmaps com problemas na API

Meu  cálculo de distância do Google Maps parou de funcionar...
segue o código que estou usando:

Código:

Option Compare Database
Option Explicit

Private Sub cmdCalcular_Click()
On Error GoTo trata_erro

'Alvaro Teixeira (ahteixeira) 2022 para MaximoAccess
'Requer função: fncAPIdistancematrix
'Requer função: separaEntreDuasStringsXML
'Requer função: DLTiraAcentos
'Requer função: DLTiraAcentos_GetCorrectChar

Dim xData, xReturn, xPos

xData = fncAPIdistancematrix() 'fazer leitura url
                
xReturn = separaEntreDuasStringsXML(xData, "<status>", "</status>") 'verifica se deu erro
If xReturn = "INVALID_REQUEST" Then MsgBox "Erro na leitura: INVALID_REQUEST", vbCritical, "": Exit Sub
    
xPos = InStr(xData, "<duration>") 'obter duracao
xData = Right(xData, Len(xData) - xPos)
Me.txtDuration = separaEntreDuasStringsXML(xData, "<text>", "</text>")

xPos = InStr(xData, "<distance>") 'obter distancia
xData = Right(xData, Len(xData) - xPos)
Me.txtDistance = separaEntreDuasStringsXML(xData, "<value>", "</value>")

Me.txtKm = txtDistance / 1000

Me.txtCusto.Enabled = True
Me.txtCustoKm.Enabled = True
Me.txtCusto = (txtCustoKm * Val(txtDistance) * 2) / 1000
Me.txtCustoKm.SetFocus
    
Exit Sub
trata_erro: ExplicaErro
End Sub

Function separaEntreDuasStringsXML(strTotal, strInicio As String, strFim As String)
On Error GoTo trata_erro

Dim i As Long, j As Long

i = InStr(strTotal, strInicio)
j = InStr(strTotal, strFim)
separaEntreDuasStringsXML = Mid(strTotal, i + Len(strInicio), j - i - Len(strInicio))
    
Exit Function
trata_erro: ExplicaErro
End Function

Function fncAPIdistancematrix() As String
On Error GoTo trata_erro

Dim xmlHTTP As XMLHTTP60
Dim sUrl, sResposta As String

Set xmlHTTP = New XMLHTTP60
sUrl = "https://maps.googleapis.com/maps/api/distancematrix/xml?destinations=" & Chr(34) & DLTiraAcentos(Me.txtDestin) & Chr(34) & "&origins=" & Chr(34) & DLTiraAcentos(Me.txtOrigin) & Chr(34) & "&units=metric&key=" & Me.txtAPIKey & "&sensor=False" & "&Mode=driving"

xmlHTTP.Open "GET", sUrl, False
xmlHTTP.send

sResposta = Trim(xmlHTTP.responseText)
fncAPIdistancematrix = sResposta
    
Exit Function
trata_erro: ExplicaErro
End Function

Public Function DLTiraAcentos(ByVal strOriginal As String)
On Error GoTo trata_erro

Dim strToReturn As String
    
strToReturn = ""
    
Dim i As Integer
For i = 1 To Len(strOriginal)
    strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, i, 1))
Next i
    
DLTiraAcentos = strToReturn
    
Exit Function
trata_erro: ExplicaErro
End Function

Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
On Error GoTo trata_erro

Dim LetrasComAcentos As String
Dim LetrasSemAcentos As String
    
LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"

Dim i As Integer

For i = 1 To Len(LetrasComAcentos)
    If strChar = Mid$(LetrasComAcentos, i, 1) Then
        DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, i, 1)
        Exit Function
    End If
Next
    
DLTiraAcentos_GetCorrectChar = strChar
    
Exit Function
trata_erro: ExplicaErro
End Function


Aparentemente minha API Key não está sendo aceita...

Já fui no console do google e a mesma está ativa, meu form estava funcionando até dia 9 de outubro.

Olá Nilton,

Pode sempre testar diretamente a "string" gerada da sUrl no browser.
Verifiquei e efetivamente dava erro na chamada, creio que será por delimitador do texto.
Veja com este código mais simples:

Código:


Private Sub cmdCalcular_Click()
'Alvaro Teixeira (ahteixeira) 2024 para MaximoAccess
'Requer função: DLTiraAcentos
'Requer função: DLTiraAcentos_GetCorrectChar

    Dim sUrl As String, XML
    Dim oXml As Object, oRequest As Object
    Set oXml = CreateObject("MSXML2.DOMDocument.6.0")
    Set oRequest = CreateObject("MSXML2.XMLHTTP.6.0")
    
    sUrl = "https://maps.googleapis.com/maps/api/distancematrix/xml?" & "origins=" & DLTiraAcentos(Me.txtOrigin) & _
           "&destinations=" & DLTiraAcentos(Me.txtDestin) & "&sensor=false&units=metric&key=" & Me.txtAPIKey
    
    oRequest.Open "GET", sUrl, False
    oRequest.send
    
    If (oRequest.status <> 200) Then
        MsgBox "HTTP Status is not OK (200): " & oRequest.responseText, vbCritical, "Error"
    Else
         Debug.Print oRequest.responseText

         XML = oRequest.responseText
    
         oXml.loadXML XML
        
         If oXml.selectSingleNode("//row/element/status").Text = "OK" Then
             Me.txtDuration = oXml.selectSingleNode("//duration/text").Text
             Me.txtDistance = oXml.selectSingleNode("//distance/text").Text
         Else
            MsgBox "Error : " + oXml.selectSingleNode("//row/element/status").Text, vbCritical, "Error"
         End If
    End If
   Set oXml = Nothing
   Set oRequest = Nothing

End Sub


Funções complementares necessárias para o código acima

Código:

Public Function DLTiraAcentos(ByVal strOriginal As String)
'By JPaulo @ 2009
    Dim strToReturn As String
    strToReturn = ""
    
    Dim i As Integer
    For i = 1 To Len(strOriginal)
        strToReturn = strToReturn & DLTiraAcentos_GetCorrectChar(Mid$(strOriginal, i, 1))
    Next i
    
    DLTiraAcentos = strToReturn
End Function

Public Function DLTiraAcentos_GetCorrectChar(ByVal strChar As String) As String
    Dim LetrasComAcentos As String
    Dim LetrasSemAcentos As String
    LetrasComAcentos = "ÁÍÓÚÉÄÏÖÜËÀÌÒÙÈÃÕÂÎÔÛÊáíóúéäïöüëàìòùèãõâîôûêÇç"
    LetrasSemAcentos = "AIOUEAIOUEAIOUEAOAIOUEaioueaioueaioueaoaioueCc"
    Dim i As Integer
    For i = 1 To Len(LetrasComAcentos)
        If strChar = Mid$(LetrasComAcentos, i, 1) Then
            DLTiraAcentos_GetCorrectChar = Mid$(LetrasSemAcentos, i, 1)
            Exit Function
        End If
    Next
    
    DLTiraAcentos_GetCorrectChar = strChar
End Function


Abraço

Olá Alvaro!

muito agradecido pela atenção...

desta maneira que vc enviou, a captura funciona perfeitamente.

ficou uma pendência: "Me.txtDistance = oXml.selectSingleNode("//distance/text").Text" vem no formato texto...

para distâncias pequenas vem por exemplo 3,3 km ou para distâncias maiores vem por exemplo 2.867 km

tenho cálculo de custo de deslocamento que é baseado no txtDistance * CustoPorKm

quando a resposta vem com vírgula calcula certo, mas quando vem com ponto calcula errado... parece que considera o ponto como vírgula

não sei onde estou errando...

pode dar uma luz ?

grato

Olá Nilton,

Se o problema é esse apenas tem que usar o "replace" para trocar o ponto por virgula, antes dos seus cálculos.
Algo assim:  Replace (SeuCampo,".", ",")

No entanto tenha atenção, pois 3,3 km são três quilómetros e trezentos metros e 2.867 km são dois mil, oitocentos e sessenta e sete quilómetros.

Abraço

olá Álvaro

sim... 3,3 kilometros funciona com o VAL(txtDistance)

já os 2.860 km calcula como se o ponto fosse uma vírgula... aí o VAL(txtDistance) considera 2,86 km

parece que o access usa o VAL() considerando ponto ou vírgula como separador de decimal

como resolver isso

grato

Olá Nilton,

Algo assim: seuCampoCalculado = val (Replace (txtDistance,".", ","))

Abraço

boa tarde Alvaro

consegui assim: Val(Replace(txtDistance, ".", ""))

substituí o ponto por nada

grato