Функция VB (VBA) определения IP адреса по имени хоста

Function ResolveAddress(ByVal ComputerName$) As String
    ' выполняет ICMP запрос (ping) до адреса ComputerName
    ' возвращает IP-адрес ComputerName$
    Dim oPingResult As Variant: On Error Resume Next
    For Each oPingResult In GetObject("winmgmts://./root/cimv2").ExecQuery _
        ("SELECT * FROM Win32_PingStatus WHERE Address = '" & ComputerName & "'")
        If IsObject(oPingResult) Then ResolveAddress = oPingResult.ProtocolAddress
    Next
End Function

Sub ПримерИспользованияResolveAddress()
    Debug.Print ResolveAddress("yandex.ru")    '  возвращает 87.250.250.11
    Debug.Print ResolveAddress("google.com")    '  возвращает 209.85.143.99
End Sub

Public Const PING_TIMEOUT As Long = 555, IP_SUCCESS As Long = 0, WS_VERSION_REQD As Long = &H101
Public Const INADDR_NONE As Long = &HFFFFFFFF, MAX_WSADescription As Long = 256, MAX_WSASYSStatus As Long = 128
Public Const SOCKET_ERROR = -1, AF_INET = 2, PF_INET = AF_INET, MAXGETHOSTSTRUCT = 1024, SOCK_STREAM = 1, MSG_PEEK = 2
 
Public Type ICMP_OPTIONS: Ttl As Byte: Tos As Byte: Flags As Byte: OptionsSize As Byte: OptionsData As Long: End Type
Public Type WSAData
    wVersion As Integer: wHighVersion As Integer:
    szDescription(0 To MAX_WSADescription) As Byte: szSystemStatus(0 To MAX_WSASYSStatus) As Byte:
    wMaxSockets As Long: wMaxUDPDG As Long: dwVendorInfo As Long
End Type
Public Type SockAddr: sin_family As Integer: sin_port As Integer: sin_addr As String * 4: sin_zero As String * 8: End Type
Public Type Inet_Address: Byte4 As String * 1: Byte3 As String * 1: Byte2 As String * 1: Byte1 As String * 1: End Type
Public Type T_Host: h_name As Long: h_aliases As Long: h_addrtype As Integer: h_length As Integer: h_addr_list As Long: End Type
 
Public Declare Function WSAGetLastError Lib "wsock32" () As Long
Public Declare Function WSAStartup Lib "wsock32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
Public Declare Function WSACleanUp Lib "wsock32" Alias "WSACleanup" () As Long
Public Declare Function GetHostName Lib "wsock32" Alias "gethostname" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Public Declare Function GetHostByName Lib "wsock32" Alias "gethostbyname" (ByVal szHost As String) As Long
Public Declare Function GetHostByAddr Lib "wsock32" Alias "gethostbyaddr" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
Public Declare Function inet_addr Lib "wsock32" (ByVal S As String) As Long
 
Public WSA_Data As WSAData, IPStruct As Inet_Address
 
' =====================================================================================================

Function HostByName(sHost As String) As String
 
    Dim S As String, p As Long, Host As T_Host, ListAddress As Long, ListAddr As Long, Address As Long
    S = String(64, 0): p = GetHostByName(sHost)
    If p = SOCKET_ERROR Then
        Exit Function
    Else
        If p <> 0 Then
            CopyMemory Host.h_name, ByVal p, Len(Host): ListAddress = Host.h_addr_list
            CopyMemory ListAddr, ByVal ListAddress, 4: CopyMemory Address, ByVal ListAddr, 4
            HostByName = InetAddrLongToString(Address)
        Else
            HostByName = "No DNS Entry"
        End If
    End If
End Function
 
Private Function InetAddrLongToString(Address As Long) As String
    CopyMemory IPStruct, Address, 4
    InetAddrLongToString = CStr(Asc(IPStruct.Byte4)) & "." & CStr(Asc(IPStruct.Byte3)) & _
                           "." & CStr(Asc(IPStruct.Byte2)) & "." & CStr(Asc(IPStruct.Byte1))
End Function
 
Function HostByAddress(ByVal sAddress As String) As String
    Dim lAddress As Long, p As Long, HostName As String, Host As T_Host
    lAddress = inet_addr(sAddress)
    p = GetHostByAddr(lAddress, 4, PF_INET)
    If p <> 0 Then
        CopyMemory Host, ByVal p, Len(Host): HostName = String(256, 0)
        CopyMemory ByVal HostName, ByVal Host.h_name, 256
        If HostName = "" Then HostByAddress = "Unable to Resolve Address"
        If InStr(HostName, Chr(0)) > 0 Then HostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)
    Else
        HostByAddress = ""
    End If
End Function

Sub ПримерИспользования()
    'В начале работы вы должны использовать функцию WSAStartup
    WSAStartup &H101, WSA_Data
 
    'Определение имени машины, зная ее IP-адрес
    Debug.Print HostByAddress("87.250.250.11")  ' возвращает "yandex.ru"
    Debug.Print HostByAddress("209.85.143.99")  ' возвращает "dy-in-f99.1e100.net"

    'Определение IP адреса машины, зная ее доменное имя
    Debug.Print HostByName("yandex.ru")    ' возвращает 87.250.250.11
    Debug.Print HostByName("google.com")    ' возвращает 209.85.143.99

    'В конце работы вы должны использовать функцию WSACleanUp
    WSACleanUp
End Sub