Визуализация движения по маршруту
Предположим, что перед нами стоит классическая задача транспортной логистики: визуализировать движение некоего объекта по заданному маршруту из нескольких промежуточных точек. Для конкретики, давайте возьмем скорый фирменный поезд "Жигули", движущийся по маршруту Москва - Самара по следующему графику (взято из Яндекс.Расписаний):
Для решения задачи нам потребуется Excel 2013-2016 с установленной надстройкой Power Map. В Excel 2016 она установлена по умолчанию, для Excel 2013 можно скачать ее бесплатную превью-версию.
Этап 1. Находим координаты
Для однозначной привязки к промежуточным пунктам маршрута лучше использовать не названия населенных пунктов (они могут повторяться либо отсутствовать в принципе в нужном месте), а нормальные географические координаты. Достаточно щелкнуть по нужному месту в Яндекс-картах или Google Maps и вы увидите широту и долготу этой точки:
Добавим найденные координаты к нашей исходной таблице расписания движения поезда:
Этап 2. Дробим перегоны
Для плавного отображения движения поезда на карте нам необходимо разделить каждый перегон на несколько участков (чем их больше, тем плавнее будет анимация). Таким образом, перед нами встает задача получить примерные координаты и время для каждой промежуточной точки. Решить проблему можно формулой либо макросом.
Например, если хотим разбить каждый перегон на шесть интервалов (т.е. пять точек), то можно реализовать все одной формулой:
Но вставлять промежуточные строки, вводить и копировать формулу на все зеленые ячейки для каждого перегона придется вручную.
Другой вариант - макрос, что гораздо удобнее при большом количестве перегонов и промежуточных точек маршрута. Откройте редактор Visual Basic на вкладке Разработчик (Developer) или нажмите сочетание клавиш Alt+F11. Вставьте в вашу книгу новый пустой модуль через меню Insert - Module и скопируйте туда этот код:
Sub MakeRouteTable()
Dim DeltaT#, DeltaS#, DeltaD#, NumSteps%, FirstRow%, LastRow%
Const MINS_IN_ONE_STEP = 1
Application.ScreenUpdating = False
FirstRow = ActiveCell.CurrentRegion.Rows(3).Row
LastRow = ActiveCell.CurrentRegion.Rows.Count + FirstRow - 3
For i = 6 To 3 Step -1
'определяем число шагов на перегоне
NumSteps = Int((Cells(i, 2) - Cells(i - 1, 2)) * 24 * 60 / MINS_IN_ONE_STEP)
'вычисляем изменение координат и времени на каждом шаге
DeltaT = (Cells(i, 2) - Cells(i - 1, 2)) / (NumSteps + 1)
DeltaS = (Cells(i, 3) - Cells(i - 1, 3)) / (NumSteps + 1)
DeltaD = (Cells(i, 4) - Cells(i - 1, 4)) / (NumSteps + 1)
'заполняем строки интервалов по каждому перегону
For j = 1 To NumSteps
Rows(i).Insert
Cells(i, 2) = Cells(i + 1, 2) - DeltaT
Cells(i, 3) = Cells(i + 1, 3) - DeltaS
Cells(i, 4) = Cells(i + 1, 4) - DeltaD
Next j
Next i
Как легко сообразить, константа MINS_IN_ONE_STEP задает количество минут в каждом шаге - можете менять ее значение по своему усмотрению. Теперь если выделить таблицу с данными или установить в нее активную ячейку, а потом запустить наш макрос сочетанием клавиш Alt+F8 или кнопкой Макросы на вкладке Разработчик (Developer - Macros), то наша таблица будет преобразована в следующий вид:
Как видите, каждый перегон теперь делится на несколько интервалов - по 1 минуте каждый.
Этап 3. Переходим к карте
Осталось совсем чуть-чуть. Выделите полученную таблицу и на вкладке Вставка нажмите кнопку 3D-карта (Insert - 3D-map):
Не перепутайте ее с кнопкой Карты (которая с глобусом) или Карты Bing (желтого цвета). После нажатия должно открыться окно надстройки Power Map.
В правой части окна на панели добавьте в группе Расположение (Location) поля широты и долготы и выберите напротив каждого название соответствующего столбца из нашей таблицы. Если все сделаете правильно, то на карте тут же должен отобразиться наш маршрут:
Теперь осталось выбрать в выпадающем списке Время (Time) столбец со значениями даты-времени из нашей таблицы и можно запускать анимацию с помощью кнопки воспроизведения в нижней части окна:
Дополнительно можно поиграться настройками слоя - кнопка Параметры слоя (Layer Options) в правом нижнем углу - и установить цвет, размер, прозрачность и т.д. отображаемых точек.
Если нажать на неприметную иконку с часами рядом с выпадающим списком Время, то можно поменять режим отображения и рисовать не маршрут, а сам поезд.
При щелчке левой кнопкой мыши по любой интересующей точке маршрута мы увидим ее подробные данные - координаты и время прохождения:
Этап 4. Несколько поездов сразу
Не секрет, что на самом деле по маршруту Москва-Самара курсируют два состава - в противофазе: когда один стартует из Москвы, другой примерно в то же время начинает движение ему навстречу из Самары. Утром один из них приходит в Самару, а другой, соответственно, в Москву и вечером процесс запускается заново. Расписание второго примерно отзеркаливает первый:
Что сделать, чтобы отобразить их на карте оба сразу?
Если по маршруту одновременно движется больше одного объекта, то данные по ним можно обработать аналогичным образом (Этапы 1 и 2) и просто добавить в продолжение нашей маршутной таблицы. А чтобы отличать поезда друг от друга, добавить еще один столбец с названием объекта:
Теперь, если построить по такой таблице еще одну визуализацию, мы будем видеть движение двух составов одновременно:
Красота :)
Ссылки по теме
Николай,-очень кстати данная тема, работа связана с транспортом и маршрутами,давно ждал что то подобное.Огромное Вам спасибо
Вставка ---> нажмите кнопку 3D-карта (Insert - 3D-map):
Предлагаю развить на предмет расчета расстояния.
Подскажите пожалуйста как это возможно реализовать с помощью google map например?
У меня есть вот такой макрос, который рассчитывает расстояние, маршрут и время в пути. Мне необходима только та часть которая отвечает за измерение расстояния. Самостоятельно разобрать не хватает знаний. Буду признателен за помощь.
Option Explicit
Public ActivationMark As Boolean
Public WasRequestGoogle As Boolean
Public MyDistance As Variant
Public MyDuration As Variant
'Задаем границы допустимых координат
Public Const Lat_min = -180, Lat_max = 180
Public Const Lon_min = -180, Lon_max = 180
'Скрываем заставку
Private Sub KillTheForm()
Unload Excelminsk
End Sub
Sub GetDistanceDurationGoogle(Address1 As String, Address2 As String)
Dim XMLDoc As Object
Dim Coord1NodeList As Object, Coord2NodeList As Object
Dim DistanceNodeList As Object, DurationNodeList As Object
Dim MyRequest As String
Dim Lat1 As String, Lon1 As String, Lat2 As String, Lon2 As String
On Error Resume Next
'Обнуляем переменные
MyDistance = ""
MyDuration = ""
'Ставим задержку между запросами
If (Address1 = Range("A3";) And Address2 = Range("B3";)) Then
Else
Application.Wait (Now + TimeValue("0:00:01";))
End If
'Кодируем адрес
Address1 = RussianStringToURLEncode_New(Address1)
Address2 = RussianStringToURLEncode_New(Address2)
MyRequest = "https://maps.googleapis.com/maps/api/directions/xml?origin=" & Address1 & "&destination=" & Address2 & "&mode=driving&language=ru"
'Debug.Print MyRequest
'Загружаем XML-документ
Set XMLDoc = CreateObject("Msxml2.DOMDocument";)
XMLDoc.async = False
If Not XMLDoc.Load(MyRequest) = True Then
MyDistance = "!ДАННЫЕ НЕ ЗАГРУЖЕНЫ"
MyDuration = "!ДАННЫЕ НЕ ЗАГРУЖЕНЫ"
Exit Sub
End If
'Считываем статус ответа
Select Case XMLDoc.SelectNodes("*/status";).Item(0).text
Case "OK"
Case "NOT_FOUND"
'Не нашел адрес точки
MyDistance = "!НЕ НАШЕЛ АДРЕС"
MyDuration = "!НЕ НАШЕЛ АДРЕС"
Exit Sub
Case "ZERO_RESULTS"
'Не может проложить маршрут
MyDistance = "!НЕТ ДОРОГИ"
MyDuration = "!НЕТ ДОРОГИ"
Exit Sub
Case "OVER_QUERY_LIMIT"
If WasRequestGoogle = False Then
Application.Wait (Now + TimeValue("0:00:02";))
WasRequestGoogle = True
Call GetDistanceDurationGoogle(Address1, Address2)
Exit Sub
Else
MyDistance = "!ПРЕВЫШЕНИЕ ЛИМИТА"
MyDuration = "!ПРЕВЫШЕНИЕ ЛИМИТА"
Exit Sub
End If
Case "REQUEST_DENIED"
MyDistance = "!ЗАПРОС ОТКЛОНЕН"
MyDuration = "!ЗАПРОС ОТКЛОНЕН"
Exit Sub
Case "INVALID_REQUEST"
MyDistance = "!НЕВЕРНЫЙ ЗАПРОС"
MyDuration = "!НЕВЕРНЫЙ ЗАПРОС"
Exit Sub
Case "UNKNOWN_ERROR"
MyDistance = "!НЕИЗВЕСТНАЯ ОШИБКА"
MyDuration = "!НЕИЗВЕСТНАЯ ОШИБКА"
Exit Sub
End Select
'Получаем координаты
Set Coord1NodeList = XMLDoc.SelectNodes("*//start_location";)
Lat1 = Coord1NodeList.Item(Coord1NodeList.Length - 1).FirstChild.text
Lon1 = Coord1NodeList.Item(Coord1NodeList.Length - 1).LastChild.text
Set Coord2NodeList = XMLDoc.SelectNodes("*//end_location";)
Lat2 = Coord2NodeList.Item(Coord2NodeList.Length - 1).FirstChild.text
Lon2 = Coord2NodeList.Item(Coord2NodeList.Length - 1).LastChild.text
'Debug.Print "Coord1=" & Lat1 & ", " & Lon1
'Debug.Print "Coord2=" & Lat2 & ", " & Lon2
'Проверяем ограничения для координат
If MyValue(Lat1) < Lat_min Or MyValue(Lat1) > Lat_max Or MyValue(Lon1) < Lon_min Or MyValue(Lon1) > Lon_max Or _
MyValue(Lat2) < Lat_min Or MyValue(Lat2) > Lat_max Or MyValue(Lon2) < Lon_min Or MyValue(Lon2) > Lon_max Then
MyDistance = "!ОГРАНИЧЕНИЕ ДЕМО"
MyDuration = "!ОГРАНИЧЕНИЕ ДЕМО"
Else
'Расстояние в метрах
Set DistanceNodeList = XMLDoc.SelectNodes("*//distance";)
MyDistance = Round(DistanceNodeList.Item(DistanceNodeList.Length - 1).FirstChild.text / 1000, 0)
'Debug.Print "MyDistance=" & MyDistance
'Время в секундах
Set DurationNodeList = XMLDoc.SelectNodes("*//duration";)
MyDuration = CLng(DurationNodeList.Item(DurationNodeList.Length - 1).FirstChild.text) / 3600 / 24
'Debug.Print "MyDuration=" & MyDuration
End If
'Удаляем XML
Set XMLDoc = Nothing
Set Coord1NodeList = Nothing
Set Coord2NodeList = Nothing
Set DistanceNodeList = Nothing
Set DurationNodeList = Nothing
'Обнуляем счетчик повторных запросов
WasRequestGoogle = False
End Sub
'Меняем адрес на понятный браузеру
Function RussianStringToURLEncode_New(ByVal txt As String) As String
Dim i As Long
Dim l As String, t As String
For i = 1 To Len(txt)
l = Mid(txt, i, 1)
Select Case AscW(l)
Case Is > 4095: t = "%" & Hex(AscW(l) \ 64 \ 64 + 224) & "%" & Hex(AscW(l) \ 64) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
Case Is > 127: t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
Case 32: t = "%20"
Case Else: t = l
End Select
RussianStringToURLEncode_New = RussianStringToURLEncode_New & t
Next
End Function
'Конвертируем широту и долготу из текста в число
Function MyValue(ByVal text As String) As Double
Dim MySeparator As String
'Считываем системный разделитель
MySeparator = Application.International(xlDecimalSeparator)
MyValue = (Trim(Replace(text, ".", MySeparator)) + 0)
End Function
Спасибо!!!!
К примеру я разобрался, что вначале мы объявляли 6 переменных и одну константа, затем отключаем видимость вычислений (для ускорения), затем определяем массив пустых ячеек (с этого места вообще непонятно). Ну а дальше работа с циклами i, j вообще загадка, находил источники в которых описывалось способы наблюдения за процедурами через вспомогательные окна VBA (типо WATCHES), через команду debag print, но вылетает 425 ошибка.
Заранее спасибо.
А как можно наоборот, с карты в интернете все точки остановки поездов (транспортные узлы) перенести в ексель?
Буду благодарна за ответ.
С уважением,
Елена:)