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

Вход

Регистрация

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

 

= Мир MS Excel/Определить Геоданные (Широту и Долготу) средствами VBA - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Определить Геоданные (Широту и Долготу) средствами VBA (Макросы/Sub)
Определить Геоданные (Широту и Долготу) средствами VBA
Валерьянка Дата: Понедельник, 08.02.2016, 09:26 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 2 ±
Замечаний: 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]
 
Ответить
СообщениеНе работает макрос, посмотрите пожалуйста, что делаю не так :(
[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]

Автор - Валерьянка
Дата добавления - 08.02.2016 в 09:26
anvg Дата: Понедельник, 08.02.2016, 11:19 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 581
Репутация: 271 ±
Замечаний: 0% ±

2016, 365
Доброе время суток
Скорее всего текст адреса должен быть либо латинскими буквами либо в символьном шестнадцатеричном коде, как в запросе для адреса "Москва" (так сработало)
[vba]
Код
urladr = "https://maps.googleapis.com/maps/api/geocode/xml?address=%D0%9C%D0%BE%D1%81%D0%BA%D0%B2%D0%B0"
[/vba]
Успехов.
 
Ответить
СообщениеДоброе время суток
Скорее всего текст адреса должен быть либо латинскими буквами либо в символьном шестнадцатеричном коде, как в запросе для адреса "Москва" (так сработало)
[vba]
Код
urladr = "https://maps.googleapis.com/maps/api/geocode/xml?address=%D0%9C%D0%BE%D1%81%D0%BA%D0%B2%D0%B0"
[/vba]
Успехов.

Автор - anvg
Дата добавления - 08.02.2016 в 11:19
SLAVICK Дата: Понедельник, 08.02.2016, 11:29 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
Цитата Валерьянка, 08.02.2016 в 09:26, в сообщении № 1
Не работает макрос,

Макрос работает. Старайтесь следующий раз указывать где Вы взяли код - будет легче понять(по крайней мере мне).
Просто этот макрос не работает с кириллицей.
Тут есть несколько вариантов:
вводить адреса в транслите(на латинице)
Дописать код для перевода в латиницу
Использовать другой код :D
Смотрите вложение. Там 1-й код - Ваш но вставлен адрес на латинице.
2-й код - отсюда немного адаптированный под Ваш пример.
[offtop]пока писал - anvg уже нашел туже причину beer [/offtop]
Добавил:
Можно добавить встроенную функцию для перевода текста в кодировку URL:
[vba]
Код
a = Application.WorksheetFunction.EncodeURL(a)
[/vba]
Это тоже что и функция листа:
Код
=КОДИР.URL(B6)

См. второй файл.
К сообщению приложен файл: LatLong.xlsm (21.0 Kb) · LatLong-1-.xlsm (22.1 Kb)


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
Цитата Валерьянка, 08.02.2016 в 09:26, в сообщении № 1
Не работает макрос,

Макрос работает. Старайтесь следующий раз указывать где Вы взяли код - будет легче понять(по крайней мере мне).
Просто этот макрос не работает с кириллицей.
Тут есть несколько вариантов:
вводить адреса в транслите(на латинице)
Дописать код для перевода в латиницу
Использовать другой код :D
Смотрите вложение. Там 1-й код - Ваш но вставлен адрес на латинице.
2-й код - отсюда немного адаптированный под Ваш пример.
[offtop]пока писал - anvg уже нашел туже причину beer [/offtop]
Добавил:
Можно добавить встроенную функцию для перевода текста в кодировку URL:
[vba]
Код
a = Application.WorksheetFunction.EncodeURL(a)
[/vba]
Это тоже что и функция листа:
Код
=КОДИР.URL(B6)

См. второй файл.

Автор - SLAVICK
Дата добавления - 08.02.2016 в 11:29
Валерьянка Дата: Четверг, 11.02.2016, 19:25 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 71
Репутация: 2 ±
Замечаний: 0% ±

Excel 2010
Всем огромное спасибо!!!
Про шестнадцатеричный код, даже в голову мысль не приходила)
Вот так всё отлично работает!
[vba]
Код

Sub LatLong()
Dim a, lat, lng, urladr As String
a = InputBox("Место назначения (Город, адрес)", "Пункт", "")
a = Replace(a, " ", "+")
    For i = 1 To Len(a)
        l = Mid(a, 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
        b = b & t
    Next
urladr = "http://maps.google.com/maps/api/geocode/xml?address=" & b & "&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]
 
Ответить
СообщениеВсем огромное спасибо!!!
Про шестнадцатеричный код, даже в голову мысль не приходила)
Вот так всё отлично работает!
[vba]
Код

Sub LatLong()
Dim a, lat, lng, urladr As String
a = InputBox("Место назначения (Город, адрес)", "Пункт", "")
a = Replace(a, " ", "+")
    For i = 1 To Len(a)
        l = Mid(a, 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
        b = b & t
    Next
urladr = "http://maps.google.com/maps/api/geocode/xml?address=" & b & "&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]

Автор - Валерьянка
Дата добавления - 11.02.2016 в 19:25
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Определить Геоданные (Широту и Долготу) средствами VBA (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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