mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Определение IP адреса и страны по доменному имени

Макрос определения страны и IP адреса по доменному имени

Макрос предназначен для вывода IP адресов и названий стран, на основании столбца с доменными именами.

В прикреплённом файле - 2 способа реализации:

1) по доменному имени определяется IP адрес (посредством команды PING - выполнения ICMP запроса),
а затем определяется страна (по IP адресу), с использованием сервиса smart-ip.net

2) используется только сервис smart-ip.net
Отправляется запрос на указанный сервис, и из полученных данных вычленяются IP адрес и название страны.

 

Код макросов (для 1 и 2 варианта):

Sub GetCountriesFromIP()
    On Error Resume Next
    Set objhttp = CreateObject("MSXML2.ServerXMLHTTP.4.0")
    Dim ra As Range, cell As Range, oPingResult As Variant
    Set ra = Range([A3], Range("A" & Rows.Count).End(xlUp))
    ra.Offset(, 1).Resize(, 2).ClearContents
 
    For Each cell In ra.Cells
        domain$ = Trim(cell): IP = ""
        If domain$ Like "*?.?*" Then
 
            ' определяем IP адрес по доменному имени
            For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
                ("SELECT * FROM Win32_PingStatus WHERE Address = '" & domain$ & "'")
                If IsObject(oPingResult) Then IP = oPingResult.ProtocolAddress
            Next
            cell.Next = IP: DoEvents
 
            ' если IP-адрес определён, получаем географическое положение IP адреса
            If cell.Next Like "*#.*#.*#.*#" Then
                URL$ = "http://ru.smart-ip.net/geoip-xml/" & cell.Next
                objhttp.Open "GET", URL$, False: objhttp.send
                cell.Next.Next = Split(Split(objhttp.responseText, "<countryName>")(1), "</countryName>")(0)
            End If
        End If
    Next cell
    Set objhttp = Nothing
End Sub

Sub GetCountriesFromDomain()
    On Error Resume Next
    Set objhttp = CreateObject("MSXML2.ServerXMLHTTP.4.0")
    Dim ra As Range, cell As Range, oPingResult As Variant
    Set ra = Range([A3], Range("A" & Rows.Count).End(xlUp))
    ra.Offset(, 1).Resize(, 2).ClearContents
 
    For Each cell In ra.Cells
        domain$ = Trim(cell): IP = ""
        If domain$ Like "*?[A-z].[A-z]*" Then
            URL$ = "http://ru.smart-ip.net/geoip-xml/" & domain$
            objhttp.Open "GET", URL$, False: objhttp.send: DoEvents
            cell.Next = Split(Split(objhttp.responseText, "<host>")(1), "</host>")(0)
            cell.Next.Next = Split(Split(objhttp.responseText, "<countryName>")(1), "</countryName>")(0)
        End If
    Next cell
    Set objhttp = Nothing
End Sub

ВложениеРазмерЗагрузкиПоследняя загрузка
ID_Domain.xls46 КБ387 недель 4 часа назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Минимальная стоимость заказа у нас, - 1500 рублей.
Тут несложно, - могу и за 1000 сделать.

Спасибо, попытаюсь сам, если не выйдет, то буду обращаться. Сколько будет стоить, может нет смысла и самому делать?

Не сложно, - можете сами сделать.
Загружаете страницу этой функцией
http://excelvba.ru/code/GetHTTPResponse
и оттуда (текстовыми функциями VBA типа Split) извлекаете значение между < title> и < /title>

Если сами не справитесь, - можем сделать под заказ.

Супер макрос! Если бы еще по домену выводилось Title (заголовок сайта) было бы просто великолепно, если не сложно сделать и будет не дорого.

2 способ у меня работает, если задать MSXML2.ServerXMLHTTP.6.0, а не 4.0.

В макросе GetCountriesFromIP данные пинга выводятся нормально а вот вторая часть макроса не чего не выводит но и ошибку не выдает.
Но все тоже самое в Microsoft Office 2010 работает без проблем.

А какую ошибку выдаёт?
На какой строке макрос вылетает?
Или в чем проявляется ошибка? Может, у вашего Excel просто не доступа в интернет (из-за файрвола)?

Под Microsoft Office 2013 не хочет работать URL$ = "http://ru.smart-ip.net/geoip-xml/" & cell.Next почему то?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _      ____        _   __  __          ____  
| | __ | __ ) | | | \/ | __ __ | _ \
| |/ / | _ \ _ | | | |\/| | \ \/ / | |_) |
| < | |_) | | |_| | | | | | > < | __/
|_|\_\ |____/ \___/ |_| |_| /_/\_\ |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.