Calcola percorso con Google Maps

Stato
Chiusa ad ulteriori risposte.

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
21.141
1.733
Como
2011MAC 2016WIN
449
Un mio amico che ha fatto nel mesi scorsi diversi viaggi per lavoro in giro per l'Italia, al suo rientro poteva chiedere il rimborso chilometrico alla sua azienda e per farlo doveva presentare un file Excel in cui c'era da indicare il luogo di partenza, il luogo di arrivo - anche con diverse tappe intermedie - quindi trovare su Google Maps i chilometri percorsi e moltiplicarli per l'importo chilometrico assegnato.

Mi ha mostrato un file con almeno 200 records, in cui c'erano indicate le varie tappe effettuate, molto spesso brevi, da un posto ad un altro.

Cercando su internet ho raccolto del codice qua e là che ho adattato per le esigenze del caso, sistemando la struttura del suo file excel in modo che tutti i calcoli sono stati ricavati dal risultato di Fuction inserite nelle apposite celle ( e sperando di non avergli creato casini! :)).

Approfittando di questa esperienza mi sono creato un altro file (che voglio qui condividere) in cui ho inserito tutti i Comuni d'Italia attuali e con due Combobox posso scegliere due Comuni per scaricarmi delle informazioni da Google Maps: in particolare, ottengo la distanza tra i due luoghi, il tempo di percorrenza, il tragitto (indicato da Google) e se voglio con un tasto posso aprire IE e farmi mostrare la mappa.

Se ci sono più distanze indicate da Google mi sceglie la prima, che di norma è quella consigliata.

Condivido nel forum questo file e se ovviamente ci sono degli errori vi prego di segnalarmeli ovvero se avete dei suggerimenti sono ben accetti.

Le varie Function
Codice:
Function googleDirezione(ByVal luogoPartenza, ByVal luogoArrivo, ByRef tempoPercorrenza, ByRef distanza, ByRef criteri, Optional ByRef strErrore = "") As Boolean
    On Error GoTo salta
    Dim strURL As String
    Dim objHTTP As Object
    Dim objDOC As Object
    Dim rotta As Object
    Dim lngDistanza As Long
    Const unitaMisura = "metrico"
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    Set objDOC = CreateObject("MSXML2.DOMDocument.6.0")
    luogoPartenza = Replace(luogoPartenza, " ", "+")
    luogoArrivo = Replace(luogoArrivo, " ", "+")
    strURL = "http://maps.googleapis.com/maps/api/directions/xml" & _
        "?origin=" & luogoPartenza & _
        "&destination=" & luogoArrivo & _
        "&sensor=false" & _
        "&units=" & unitaMisura
    With objHTTP
        .Open "GET", strURL, False
        .setRequestHeader "Content-Type", "application/x-www-form-URLEncoded"
        .Send
        objDOC.LoadXML .ResponseText
    End With
    With objDOC
        If .SelectSingleNode("//status").Text = "OK" Then
            lngDistanza = .SelectSingleNode("/DirectionsResponse/route/leg/distance/value").Text
            Select Case unitaMisura
                Case "imperial": distanza = Round(lngDistanza * 0.00062137, 1)
                Case "metrico": distanza = Round(lngDistanza / 1000, 1)
            End Select
            tempoPercorrenza = .SelectSingleNode("/DirectionsResponse/route/leg/duration/value").Text
            tempoPercorrenza = TimeGoogle(tempoPercorrenza)
            For Each rotta In .SelectSingleNode("//route/leg").ChildNodes
                If rotta.BaseName = "step" Then
                    criteri = criteri & rotta.SelectSingleNode("html_instructions").Text & " - " & rotta.SelectSingleNode("distance/text").Text & vbCrLf
                End If
            Next
            criteri = PulisciHTML(criteri)
        Else
            strErrore = .SelectSingleNode("//status").Text
            GoTo salta
        End If
    End With
    googleDirezione = True
    GoTo CleanExit
salta:
    If strErrore = "" Then strErrore = Err.Description
    distanza = -1
    tempoPercorrenza = "00:00"
    criteri = ""
    googleDirezione = False
CleanExit:
    Set objDOC = Nothing
    Set objHTTP = Nothing
End Function


Function durataViaggio(ByVal strPartenza, ByVal strArrivo) As String
    Dim tempoPercorrenza As String
    Dim distanza As String
    Dim criteri As String
    Dim strErrore As String
    If googleDirezione(strPartenza, strArrivo, tempoPercorrenza, distanza, criteri, strErrore) Then
        durataViaggio = tempoPercorrenza
    Else
        durataViaggio = strErrore
    End If
End Function


Function CalcolaDistanzaGoogle(ByVal strPartenza, ByVal strArrivo) As String
    Dim tempoPercorrenza As String
    Dim distanza As String
    Dim strErrore As String
    Dim criteri As String
    If googleDirezione(strPartenza, strArrivo, tempoPercorrenza, distanza, criteri, strErrore) Then
        CalcolaDistanzaGoogle = distanza
    Else
        CalcolaDistanzaGoogle = strErrore
    End If
End Function


Function MostraPercorsoGoogle(ByVal strPartenza, ByVal strArrivo) As String
    Dim tempoPercorrenza As String
    Dim distanza As String
    Dim strErrore As String
    Dim criteri As String
    If googleDirezione(strPartenza, strArrivo, tempoPercorrenza, distanza, criteri, strErrore) Then
        MostraPercorsoGoogle = criteri
    Else
        MostraPercorsoGoogle = strErrore
    End If
End Function


Public Function TimeGoogle(ByVal secondi As Double)
    Dim minuti As Long
    Dim ore As Long
    minuti = Fix(secondi / 60)
    ore = Fix(minuti / 60)
    minuti = minuti - (ore * 60)
    TimeGoogle = Format(ore, "00") & ":" & Format(minuti, "00")
End Function
Function PulisciHTML(ByVal strHTML)
    Dim strArry1() As String
    Dim strArry2() As String
    Dim s As Integer
    strArry1 = Split(strHTML, "<")
    For s = LBound(strArry1) To UBound(strArry1)
        strArry2 = Split(strArry1(s), ">")
        If UBound(strArry2) > 0 Then
            strArry1(s) = strArry2(1)
        Else
            strArry1(s) = strArry2(0)
        End If
    Next
    PulisciHTML = Join(strArry1)
End Function

La routine che mostra le indicazioni stradali in una ListBox (Ho usato la ListBox in una UserForm poiché la finestra del MsgBox era troppo piccolo per contenere tutto il testo)
Codice:
Private Sub UserForm_Initialize()
Me.Caption = "INDICAZIONI STRADALI" & "  " & Range("B1") & " - " & Range("B2")
    Dim matrix
    matrix = Split(MostraPercorsoGoogle(Range("B1"), Range("B2")), vbCrLf)
    ListBox1.List() = matrix
End Sub
La routine che apre IE e mostra la mappa
Codice:
Sub MostraPercorso()
    Dim IE As Object
    Dim partenza As String
    Dim destinazione As String
    Application.ScreenUpdating = False
    partenza = Range("B1") & ",+" & Range("C1") & "/"
    destinazione = Range("B2") & ",+" & Range("B2")
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.Navigate "https://www.google.it/maps/dir/" & partenza & "+" & destinazione
    Application.ScreenUpdating = True
End Sub

PER FUNZIONARE E' NECESSARIO IL COLLEGAMENTO A INTERNET
 

Allegati

  • Like
Reactions: Mattia27
Stato
Chiusa ad ulteriori risposte.

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!