Макрос Excel для получения расстояний между городами с сайта Ati.su

На листе три именованные ячейки: Город1, Город2 и Город5. Заполнив названия городов и нажав на кнопку, получим расстояние между городами 1 и 2 через город5. Данные берутся с сайта Ati.su
Код макроса:
Option Explicit
'Расчет расстояний между городами через сайт Ati.su
'Должна быть включена в Tools\References - Microsoft HTML Object Lib!
Sub CityRoute()
Dim data As String, url As String, txt As String
Dim path As String, time As String
Dim City1 As String, City2 As String, City5 As String
Dim i As Integer, cnt As Integer
ActiveSheet.Range("Расстояние") = "0"
ActiveSheet.Range("Время_в_пути") = "0"
Application.ScreenUpdating = False
On Error GoTo ErrMsg
'Задание исходных данных
City1 = ActiveSheet.Range("Город1") 'откуда
City2 = ActiveSheet.Range("Город2") 'через
City5 = ActiveSheet.Range("Город5") 'куда
If (City1 = "") Or (City5 = "") Then
MsgBox "Задайте начало и конец маршрута!", vbInformation + vbOKOnly, "Ошибка!"
Exit Sub
End If
'Делаем запрос на сайт
data = "City1=" + City1 + "&City2=" + City2 + "&City5=" + City5
url = "http://ati.su/Trace/"
Dim xml As Object
Set xml = CreateObject("MSXML2.ServerXMLHTTP")
With xml
.Open "POST", url, False
.setRequestHeader "Accept", "text/html"
.setRequestHeader "Accept-Charset", "windows-1251"
.setRequestHeader "Keep-Alive", "300"
.setRequestHeader "Connection", "keep-alive"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send data
End With
'Перегоняем код страницы
Dim htm As IHTMLDocument
Set htm = CreateObject("HTMLFile")
htm.body.innerHTML = xml.responseText
'проверим, есть ли нужные данные в таблице
Dim El As IHTMLElement
On Error GoTo ErrTableNotFound
i = 0
For Each El In htm.getElementsByTagName("TR")
If El.className = "road_tr" Then
i = 1
Exit For
End If
Next El
If i = 0 Then Error (0)
'Парсим полученные данные
Dim StrArr() As String
data = ""
cnt = 1
On Error GoTo ErrMsg
For Each El In htm.getElementsByTagName("TR")
If El.className = "road_tr" Then
txt = Trim(El.outerText)
StrArr = Split(txt, vbCrLf) 'заполним массив данных, разделитель - перенос строки
If UBound(StrArr) - LBound(StrArr) >= 2 Then 'если массив хотя бы два элемента...
txt = Trim(StrArr(LBound(StrArr))) 'здесь - город
If txt "" Then 'если город не пустой, то выводим данные...
data = data + Str(cnt) + vbTab + _
Format(Left(txt, 16), "!" + String(16, "@")) + vbTab + _
Trim(StrArr(UBound(StrArr))) + vbCrLf
cnt = cnt + 1
End If
End If
End If
Next El
If Len(data) = 0 Then Error (0)
'Достаем расстояние между городами и время в пути
On Error GoTo ErrDistanceNotFound
path = htm.getElementById("ctl00_ctl00_main_PlaceHolderMain_atiTrace_lblTotalDistance").innerHTML
time = htm.getElementById("ctl00_ctl00_main_PlaceHolderMain_atiTrace_lblTotalTime").innerHTML
ActiveSheet.Range("Расстояние") = path
ActiveSheet.Range("Время_в_пути") = time
'Покажем окно с данными
UserForm.TextBox.Text = data
UserForm.LabelPath.Caption = "Всего " + path + " км"
UserForm.LabelTime.Caption = time + " часов"
UserForm.Show
'Всё хорошо, освобождаем ресурсы и выходим
GoTo FreeResource
Exit Sub
'====================================================================
ErrTableNotFound:
MsgBox "Таблица с результатом счета не найдена!" + vbCrLf + _
"Проверьте имена городов.", vbCritical + vbOKOnly, "Ошибка!"
GoTo FreeResource
ErrDistanceNotFound:
MsgBox "Расстояние не найдено!" + vbCrLf + _
"Проверьте имена городов.", vbCritical + vbOKOnly, "Ошибка!"
GoTo FreeResource
ErrMsg:
MsgBox "Непредвиденная ошибка!" + vbCrLf + _
"Что-то пошло не так.", vbCritical + vbOKOnly, "Ошибка!"
GoTo FreeResource
'Освобождаем ресурсы и валим
FreeResource:
Application.ScreenUpdating = True
Set xml = Nothing
Set htm = Nothing
Set El = Nothing
End Sub

Оригинальная форма с сайта Ati.su:











Расчет расстояния между городами
От:
До:
Через:

(на ATI.su)