Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Геоданные XML (google) определить расстояние с помощью VBA - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Геоданные XML (google) определить расстояние с помощью VBA (Макросы/Sub)
Геоданные XML (google) определить расстояние с помощью VBA
Валерьянка Дата: Вторник, 02.02.2016, 00:52 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 1 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток!
В просторах интернета готовых решений найти не удалось, но тема и сама затея может быть кому-нибудь будет интересной и полезной.

Цель определить расстояние между городами, местами, конкретными адресами и тд
Полазив по гуглу, и экспериментируя руками, получилось найти структуру ответа на запрос по расстоянию на карте между пунктами в виде xml

Атрибут distance дает расстояние в метрах.

Распарсить xml я не могу :( т.к. этот отрезок vba мне дается тяжело

[vba]
Код

Sub DistanceXML()
    Dim urladr, a, b
    a = InputBox("Пункт А", "А", "")
    b = InputBox("Пункт Б", "Б", "")
    a = Replace(a, " ", "+")
    a = Replace(a, ",", "+")
    b = Replace(b, " ", "+")
    b = Replace(b, ",", "+")
    
    urladr = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & a & "|Seattle&destinations=" & b
   ' далее мне нужно распарсить код из гугл и получить цифры - дистанцию между пунктом А и Б в метрах distance -> value
   '<distance>
   '<value>11797</value>...
     '</distance>
    
     MsgBox "Расстояние " & distance & " метров :)"
End Sub
[/vba]
 
Ответить
СообщениеДоброго времени суток!
В просторах интернета готовых решений найти не удалось, но тема и сама затея может быть кому-нибудь будет интересной и полезной.

Цель определить расстояние между городами, местами, конкретными адресами и тд
Полазив по гуглу, и экспериментируя руками, получилось найти структуру ответа на запрос по расстоянию на карте между пунктами в виде xml

Атрибут distance дает расстояние в метрах.

Распарсить xml я не могу :( т.к. этот отрезок vba мне дается тяжело

[vba]
Код

Sub DistanceXML()
    Dim urladr, a, b
    a = InputBox("Пункт А", "А", "")
    b = InputBox("Пункт Б", "Б", "")
    a = Replace(a, " ", "+")
    a = Replace(a, ",", "+")
    b = Replace(b, " ", "+")
    b = Replace(b, ",", "+")
    
    urladr = "https://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & a & "|Seattle&destinations=" & b
   ' далее мне нужно распарсить код из гугл и получить цифры - дистанцию между пунктом А и Б в метрах distance -> value
   '<distance>
   '<value>11797</value>...
     '</distance>
    
     MsgBox "Расстояние " & distance & " метров :)"
End Sub
[/vba]

Автор - Валерьянка
Дата добавления - 02.02.2016 в 00:52
SLAVICK Дата: Вторник, 02.02.2016, 01:26 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1924
Репутация: 650 ±
Замечаний: 0% ±

2007,2010,2013,2016
Цитата Валерьянка, 02.02.2016 в 00:52, в сообщении № 1
В просторах интернета готовых решений найти не удалось

Плохо искали :D
Вот тут есть и тут
По моему что-то даже тут на форуме было.


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
Цитата Валерьянка, 02.02.2016 в 00:52, в сообщении № 1
В просторах интернета готовых решений найти не удалось

Плохо искали :D
Вот тут есть и тут
По моему что-то даже тут на форуме было.

Автор - SLAVICK
Дата добавления - 02.02.2016 в 01:26
Валерьянка Дата: Вторник, 02.02.2016, 01:48 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 1 ±
Замечаний: 0% ±

Excel 2010
Плохо искали

Огромное спасибо всё получилось)
[vba]
Код
Public Sub GetDistance()
Dim a, b, GetDistance  As String
    a = InputBox("Пункт А", "А", "")
    b = InputBox("Пункт Б", "Б", "")
    
    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=pl&sensor=false"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(a, " ", "+") & secondVal & Replace(b, " ", "+") & 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, """distance"" : {") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = """value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHTTP.responseText)
    tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
    GetDistance = CDbl(tmpVal)
    MsgBox GetDistance
    Exit Sub
ErrorHandl:
    GetDistance = -1
End Sub
[/vba]
 
Ответить
Сообщение
Плохо искали

Огромное спасибо всё получилось)
[vba]
Код
Public Sub GetDistance()
Dim a, b, GetDistance  As String
    a = InputBox("Пункт А", "А", "")
    b = InputBox("Пункт Б", "Б", "")
    
    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=pl&sensor=false"
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    URL = firstVal & Replace(a, " ", "+") & secondVal & Replace(b, " ", "+") & 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, """distance"" : {") = 0 Then GoTo ErrorHandl
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = """value"".*?([0-9]+)": regex.Global = False
    Set matches = regex.Execute(objHTTP.responseText)
    tmpVal = Replace(matches(0).SubMatches(0), ".", Application.International(xlListSeparator))
    GetDistance = CDbl(tmpVal)
    MsgBox GetDistance
    Exit Sub
ErrorHandl:
    GetDistance = -1
End Sub
[/vba]

Автор - Валерьянка
Дата добавления - 02.02.2016 в 01:48
doober Дата: Вторник, 02.02.2016, 01:50 | Сообщение № 4
Группа: Друзья
Ранг: Обитатель
Сообщений: 330
Репутация: 179 ±
Замечаний: 0% ±

Excel 2007
А так намного короче.
[vba]
Код
    Set xmlDoc = CreateObject("Microsoft.XMLDOM")
    xmlDoc.Load urladr
    Do While xmlDoc.readyState <> 4
        DoEvents
    Loop
    distance = xmlDoc.SelectSingleNode("//distance/value").Text
    MsgBox "Расстояние " & distance & " метров :)"
[/vba]


 
Ответить
СообщениеА так намного короче.
[vba]
Код
    Set xmlDoc = CreateObject("Microsoft.XMLDOM")
    xmlDoc.Load urladr
    Do While xmlDoc.readyState <> 4
        DoEvents
    Loop
    distance = xmlDoc.SelectSingleNode("//distance/value").Text
    MsgBox "Расстояние " & distance & " метров :)"
[/vba]

Автор - doober
Дата добавления - 02.02.2016 в 01:50
Валерьянка Дата: Вторник, 02.02.2016, 02:14 | Сообщение № 5
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 1 ±
Замечаний: 0% ±

Excel 2010
А так намного короче

Действительно:D
Спасибо огромное!!
Doober, просто превосходно!!!
Благодарю за помощь!!!
 
Ответить
Сообщение
А так намного короче

Действительно:D
Спасибо огромное!!
Doober, просто превосходно!!!
Благодарю за помощь!!!

Автор - Валерьянка
Дата добавления - 02.02.2016 в 02:14
Валерьянка Дата: Четверг, 04.02.2016, 14:44 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 1 ±
Замечаний: 0% ±

Excel 2010
Не могу понять, что делаю не так, почему-то не работает у меня.
посмотрите код, пожалуйста
[vba]
Код

Sub LatLong()
Dim a, lat, lng, urladr As String
a = InputBox("Место назначения (Город, адрес)", "Пункт", "")
urladr = "http://maps.google.com/maps/api/geocode/xml?address=" & Replace(a, " ", "+") & "&sensor=false"
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.Load urladr
Do While xmlDoc.readyState <> 4
DoEvents
Loop
lat = xmlDoc.SelectSingleNode("//location/lat").Text
lng = xmlDoc.SelectSingleNode("//location/lng").Text
    MsgBox lat & "," & lng
End Sub
[/vba]
[moder]Какое отношение этот вопрос имеет к расчету расстояния?
Создайте новую тему.[/moder]


Сообщение отредактировал SLAVICK - Четверг, 04.02.2016, 15:47
 
Ответить
СообщениеНе могу понять, что делаю не так, почему-то не работает у меня.
посмотрите код, пожалуйста
[vba]
Код

Sub LatLong()
Dim a, lat, lng, urladr As String
a = InputBox("Место назначения (Город, адрес)", "Пункт", "")
urladr = "http://maps.google.com/maps/api/geocode/xml?address=" & Replace(a, " ", "+") & "&sensor=false"
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
xmlDoc.Load urladr
Do While xmlDoc.readyState <> 4
DoEvents
Loop
lat = xmlDoc.SelectSingleNode("//location/lat").Text
lng = xmlDoc.SelectSingleNode("//location/lng").Text
    MsgBox lat & "," & lng
End Sub
[/vba]
[moder]Какое отношение этот вопрос имеет к расчету расстояния?
Создайте новую тему.[/moder]

Автор - Валерьянка
Дата добавления - 04.02.2016 в 14:44
Валерьянка Дата: Пятница, 12.02.2016, 03:17 | Сообщение № 7
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 1 ±
Замечаний: 0% ±

Excel 2010
Googlе рассчитывает расстояние исходя из маршрута и средства передвижения, загруженности дороги и т.п.
потому расстояние может постоянно изменятся.
Наиболее точное геодезическое расстояние, для оценки отдаленности, можно получить от пункта А до Б по прямой

Вот что у меня получилось собрать :)

[vba]
Код
Sub Расстояние()
Const pi = 3.14159265358979 ' определяем константу pi
lat1 = 56.7529556 ' Широта А
lng1 = 37.1969234  ' Долгота А
lat2 = 56.7523821 ' Широта Б
lng2 = 37.1976746 ' Долгота Б
' переводим градусы в радианы
GradToRadLat1 = lat1 * pi / 180 ' Радианы Широты А
GradToRadLng1 = lng1 * pi / 180 ' Радианы Долготы А
GradToRadLat2 = lat2 * pi / 180 ' Радианы Широты Б
GradToRadLng2 = lng2 * pi / 180 ' Радианы Долготы Б
a = 6378137 ' экваториальный радиус земли (метров)
f = 1 / 298.257223563 ' сжатие
b = a * (1 - f) ' полярный радиус
GSinLat = (Sin((GradToRadLat1 - GradToRadLat2) / 2) ^ 2) 'Гаверсинус широты
GSinLng = (Sin((GradToRadLng1 - GradToRadLng2) / 2) ^ 2) 'Гаверсинус долготы
CosLat = Cos(GradToRadLat1) * Cos(GradToRadLat2) 'Произведение косинусов широт
'вычисление арксинуса угла (Sqr(GSinLat + GSinLng * CosLat)
x = Sqr(GSinLat + GSinLng * CosLat)
Arcsin = Atn(x / Sqr(-x * x + 1))
'расчет дистанции
dist = (a + b) * Arcsin
MsgBox dist
End Sub
[/vba]

Как получить координаты смотрите здесь
 
Ответить
СообщениеGooglе рассчитывает расстояние исходя из маршрута и средства передвижения, загруженности дороги и т.п.
потому расстояние может постоянно изменятся.
Наиболее точное геодезическое расстояние, для оценки отдаленности, можно получить от пункта А до Б по прямой

Вот что у меня получилось собрать :)

[vba]
Код
Sub Расстояние()
Const pi = 3.14159265358979 ' определяем константу pi
lat1 = 56.7529556 ' Широта А
lng1 = 37.1969234  ' Долгота А
lat2 = 56.7523821 ' Широта Б
lng2 = 37.1976746 ' Долгота Б
' переводим градусы в радианы
GradToRadLat1 = lat1 * pi / 180 ' Радианы Широты А
GradToRadLng1 = lng1 * pi / 180 ' Радианы Долготы А
GradToRadLat2 = lat2 * pi / 180 ' Радианы Широты Б
GradToRadLng2 = lng2 * pi / 180 ' Радианы Долготы Б
a = 6378137 ' экваториальный радиус земли (метров)
f = 1 / 298.257223563 ' сжатие
b = a * (1 - f) ' полярный радиус
GSinLat = (Sin((GradToRadLat1 - GradToRadLat2) / 2) ^ 2) 'Гаверсинус широты
GSinLng = (Sin((GradToRadLng1 - GradToRadLng2) / 2) ^ 2) 'Гаверсинус долготы
CosLat = Cos(GradToRadLat1) * Cos(GradToRadLat2) 'Произведение косинусов широт
'вычисление арксинуса угла (Sqr(GSinLat + GSinLng * CosLat)
x = Sqr(GSinLat + GSinLng * CosLat)
Arcsin = Atn(x / Sqr(-x * x + 1))
'расчет дистанции
dist = (a + b) * Arcsin
MsgBox dist
End Sub
[/vba]

Как получить координаты смотрите здесь

Автор - Валерьянка
Дата добавления - 12.02.2016 в 03:17
SLAVICK Дата: Пятница, 12.02.2016, 11:16 | Сообщение № 8
Группа: Модераторы
Ранг: Старожил
Сообщений: 1924
Репутация: 650 ±
Замечаний: 0% ±

2007,2010,2013,2016
Цитата Валерьянка, 12.02.2016 в 03:17, в сообщении № 7
Вот что у меня получилось собрать :)

Это конечно хорошо - Вы молодец. Только зачем опять изобретать велосипед? - можно же было просто спросить
Такой расчет давно есть даже в формульном виде, в том числе здесь на форуме. yes
И как по мне формулу намного проще применить в таблицы :D .
А на счет точности - это кому что нужно. Если нужно расстояние напрямую - то так, но если нужно просчитать затраты на бензин, например, то река или гора в раз перечеркнет эти расчеты.
Здесь и приходит на помощь googleapis :D


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
Цитата Валерьянка, 12.02.2016 в 03:17, в сообщении № 7
Вот что у меня получилось собрать :)

Это конечно хорошо - Вы молодец. Только зачем опять изобретать велосипед? - можно же было просто спросить
Такой расчет давно есть даже в формульном виде, в том числе здесь на форуме. yes
И как по мне формулу намного проще применить в таблицы :D .
А на счет точности - это кому что нужно. Если нужно расстояние напрямую - то так, но если нужно просчитать затраты на бензин, например, то река или гора в раз перечеркнет эти расчеты.
Здесь и приходит на помощь googleapis :D

Автор - SLAVICK
Дата добавления - 12.02.2016 в 11:16
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Геоданные XML (google) определить расстояние с помощью VBA (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!