MappingFunctions.bas

Attribute VB_Name = "Module1"
Option Explicit

Function mapDistance(address1 As String, address2 As String, apikey, Optional mode As String = "driving")
    Dim httpObject As Object
    Set httpObject = CreateObject("MSXML2.XMLHTTP")

    Dim encodedAddress1, encodedAddress2 As String
    encodedAddress1 = WorksheetFunction.EncodeURL(address1)
    encodedAddress2 = WorksheetFunction.EncodeURL(address2)
    
    
    Dim sURL As String
    sURL = "https://maps.googleapis.com/maps/api/directions/json?origin=" & encodedAddress1 & "&destination=" & encodedAddress2 & "&key=" & apikey & "&mode=" & mode
    
    Debug.Print "test"
    
    Debug.Print sURL
    
    Dim sRequest, sGetResult As String
    sRequest = sURL
    httpObject.Open "GET", sRequest, False
    httpObject.Send
    sGetResult = httpObject.ResponseText
    
    'Debug.Print sGetResult

    Dim vJSON
    Dim sState As String
    
    JSON.Parse sGetResult, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON": End
    'Debug.Print vJSON
    
    'Going to default to route 0, but this could be changed or customized later
    
    Dim distanceVal
    Dim distanceExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].distance.text", distanceVal, distanceExists
    
    Debug.Print distanceVal
    'MsgBox "Completed"
    
    mapDistance = distanceVal

End Function

Function mapDistanceRawVal(address1 As String, address2 As String, apikey, Optional mode As String = "driving")
    Dim httpObject As Object
    Set httpObject = CreateObject("MSXML2.XMLHTTP")

    Dim encodedAddress1, encodedAddress2 As String
    encodedAddress1 = WorksheetFunction.EncodeURL(address1)
    encodedAddress2 = WorksheetFunction.EncodeURL(address2)
    
    
    Dim sURL As String
    sURL = "https://maps.googleapis.com/maps/api/directions/json?origin=" & encodedAddress1 & "&destination=" & encodedAddress2 & "&key=" & apikey & "&mode=" & mode
    
    Debug.Print "test"
    
    Debug.Print sURL
    
    Dim sRequest, sGetResult As String
    sRequest = sURL
    httpObject.Open "GET", sRequest, False
    httpObject.Send
    sGetResult = httpObject.ResponseText
    
    'Debug.Print sGetResult

    Dim vJSON
    Dim sState As String
    
    JSON.Parse sGetResult, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON": End
    'Debug.Print vJSON
    
    'Going to default to route 0, but this could be changed or customized later
    
    Dim distanceVal
    Dim distanceExists
    
    'Returns value in meters
    jsonExt.selectElement vJSON, ".routes[0].legs[0].distance.value", distanceVal, distanceExists
    
    Debug.Print distanceVal
    'MsgBox "Completed"
    
    mapDistanceRawVal = distanceVal

End Function

Function mapTime(address1 As String, address2 As String, apikey, Optional mode As String = "driving")
    Dim httpObject As Object
    Set httpObject = CreateObject("MSXML2.XMLHTTP")

    Dim encodedAddress1, encodedAddress2 As String
    encodedAddress1 = WorksheetFunction.EncodeURL(address1)
    encodedAddress2 = WorksheetFunction.EncodeURL(address2)
    
    Dim sURL As String
    sURL = "https://maps.googleapis.com/maps/api/directions/json?origin=" & encodedAddress1 & "&destination=" & encodedAddress2 & "&key=" & apikey & "&mode=" & mode
    
    Debug.Print "test"
    
    Debug.Print sURL
    
    Dim sRequest, sGetResult As String
    sRequest = sURL
    httpObject.Open "GET", sRequest, False
    httpObject.Send
    sGetResult = httpObject.ResponseText
    
    'Debug.Print sGetResult

    Dim vJSON
    Dim sState As String
    
    JSON.Parse sGetResult, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON": End
    'Debug.Print vJSON
    
    'Going to default to route 0, but this could be changed or customized later
    
    Dim durationVal
    Dim durationExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].duration.text", durationVal, durationExists
    
    Debug.Print durationVal
    'MsgBox "Completed"
    
    mapTime = durationVal

End Function
Function mapTimeRawVal(address1 As String, address2 As String, apikey, Optional mode As String = "driving")
    Dim httpObject As Object
    Set httpObject = CreateObject("MSXML2.XMLHTTP")

    Dim encodedAddress1, encodedAddress2 As String
    encodedAddress1 = WorksheetFunction.EncodeURL(address1)
    encodedAddress2 = WorksheetFunction.EncodeURL(address2)
    
    
    Dim sURL As String
    sURL = "https://maps.googleapis.com/maps/api/directions/json?origin=" & encodedAddress1 & "&destination=" & encodedAddress2 & "&key=" & apikey & "&mode=" & mode
    
    Debug.Print "test"
    
    Debug.Print sURL
    
    Dim sRequest, sGetResult As String
    sRequest = sURL
    httpObject.Open "GET", sRequest, False
    httpObject.Send
    sGetResult = httpObject.ResponseText
    
    'Debug.Print sGetResult

    Dim vJSON
    Dim sState As String
    
    JSON.Parse sGetResult, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON": End
    'Debug.Print vJSON
    
    'Going to default to route 0, but this could be changed or customized later
    
    Dim durationVal
    Dim durationExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].duration.value", durationVal, durationExists
    
    Debug.Print durationVal
    'MsgBox "Completed"
    
    mapTimeRawVal = durationVal

End Function
Function mapAllVal(address1 As String, address2 As String, apikey, Optional mode As String = "driving")
    Dim httpObject As Object
    Set httpObject = CreateObject("MSXML2.XMLHTTP")

    Dim encodedAddress1, encodedAddress2 As String
    encodedAddress1 = WorksheetFunction.EncodeURL(address1)
    encodedAddress2 = WorksheetFunction.EncodeURL(address2)
    
    
    Dim sURL As String
    sURL = "https://maps.googleapis.com/maps/api/directions/json?origin=" & encodedAddress1 & "&destination=" & encodedAddress2 & "&key=" & apikey & "&mode=" & mode
    
    'Debug.Print "mapAllVal"
    
    'Debug.Print sURL
    
    Dim sRequest, sGetResult As String
    sRequest = sURL
    httpObject.Open "GET", sRequest, False
    httpObject.Send
    sGetResult = httpObject.ResponseText
    
    'Debug.Print sGetResult

    Dim vJSON
    Dim sState As String
    
    JSON.Parse sGetResult, vJSON, sState
    If sState = "Error" Then MsgBox "Invalid JSON": End
    'Debug.Print vJSON
    
    'Going to default to route 0, but this could be changed or customized later
    
    Dim distanceVal
    Dim distanceExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].distance.text", distanceVal, distanceExists
    
    Dim distanceRawValVal
    Dim distanceRawValExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].distance.value", distanceRawValVal, distanceRawValExists
    
    Dim durationVal
    Dim durationExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].duration.text", durationVal, durationExists
    
    Dim durationRawValVal
    Dim durationRawValExists
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].duration.value", durationRawValVal, durationRawValExists
    
    Debug.Print distanceVal & ":" & distanceRawValVal & ":" & durationVal & ":" & durationRawValVal
    'MsgBox "Completed"
    
    mapAllVal = distanceVal & ":" & distanceRawValVal & ":" & durationVal & ":" & durationRawValVal
    

End Function

Function mapClosest(address1 As String, addresses As Range, apikey, Optional mode As String = "driving")
    'Debug.Print "Row count: " & addresses.Rows.Count
    'Indexed from 1? Who does that???
    'Debug.Print addresses(1)
    
    Dim Responses()
    ReDim Responses(addresses.Rows.Count)
    Dim closest
    Dim shortestTime As Long
    shortestTime = 2147483647
    'Debug.Print shortestTime
    Dim closestAddress
    
    Dim encodedAddress1, encodedAddress2 As String
    encodedAddress1 = WorksheetFunction.EncodeURL(address1)
    
    Dim i As Integer
    For i = 1 To addresses.Rows.Count
        Dim httpObject As Object
        Set httpObject = CreateObject("MSXML2.XMLHTTP")
        
        encodedAddress2 = WorksheetFunction.EncodeURL(addresses(i))
        
        Dim sURL As String
        sURL = "https://maps.googleapis.com/maps/api/directions/json?origin=" & encodedAddress1 & "&destination=" & encodedAddress2 & "&key=" & apikey & "&mode=" & mode
        
        'Debug.Print "test"
        
        'Debug.Print sURL
        
        Dim sRequest, sGetResult As String
        sRequest = sURL
        httpObject.Open "GET", sRequest, False
        httpObject.Send
        sGetResult = httpObject.ResponseText
        
        Responses(i) = sGetResult
        
        Dim vJSON
        Dim sState As String
        
        JSON.Parse sGetResult, vJSON, sState
        If sState = "Error" Then MsgBox "Invalid JSON": End
        
        Dim durationRawValVal
        Dim durationRawValExists
    
        jsonExt.selectElement vJSON, ".routes[0].legs[0].duration.value", durationRawValVal, durationRawValExists
        
        If (durationRawValVal < shortestTime) Then
            shortestTime = durationRawValVal
            closest = i
            closestAddress = addresses(i)
            'Debug.Print "test in if"
        End If
    Next i
    
    JSON.Parse Responses(closest), vJSON, sState
    Dim durationRawValVal2
    Dim durationRawValExists2
    
    jsonExt.selectElement vJSON, ".routes[0].legs[0].duration.value", durationRawValVal2, durationRawValExists2
    
    'Debug.Print "Shortest duration from json " & durationRawValVal2
    'Debug.Print "Shortest time val: " & shortestTime / 60
    
    'Range to normal VBA array
    'Dim X
    
    'X = Application.Transpose(addresses)
    'Debug.Print "X" & X(2)

    mapClosest = (shortestTime / 60) & ":" & closestAddress
    
    'Debug.Print sGetResult

End Function

Sub test()

    MsgBox mapAllVal("Disneyland", "Universal Studios Hollywood", "APIKEYGOESHERE")
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"
Debug.Print "No API Key for you!"



End Sub