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 КБ4012 недель 4 дня назад

Комментарии

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

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

Удалите в своём файле самую верхнюю строку кода — Option Explicit
Она заставляет вас объявлять все переменные в коде (что необязательно, в общем-то)

Привет!
При копировании в свою книгу код не работает,
выдает ошибку что переменные: domain$, IP, objhttp не заданы.

С чем это может быть связано? В примере они тоже нигде не объявлены, но работает.

Спасибо

Минимальная стоимость заказа у нас, - 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-арт.

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

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