Excel VBA для получения IP-адреса из домена

Question

Я пытаюсь написать скрипт VB для MS Excel, чтобы получить IP-адрес из домена. В настоящее время я использую ping, но он слишком медленный и занимает до 19 секунд.

Я создал специальную функцию для этого:

Public Function RunShell(Url As String) As String
Dim ReplacedURL As String
ReplacedURL = Replace(Url, "https://", "")
ReplacedURL = Replace(ReplacedURL, "http://", "")
If InStr(ReplacedURL, "/") > 0 Then
ReplacedURL = Mid(ReplacedURL, 1, InStr(ReplacedURL, "/") - 1)
End If
Dim Command As String
Command = "cmd /c """ & "ping " & ReplacedURL & "|clip"""
CreateObject("WScript.Shell").Run Command, 0, True
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
Dim CommandOutput As String
CommandOutput = DataObj.GetText
Dim IPAddress As String
IPAddress = ""
If InStr(CommandOutput, "[") > 0 And InStr(CommandOutput, "]") > 0 Then
IPAddress = Mid(CommandOutput, InStr(CommandOutput, "[") + 1,             InStr(CommandOutput, "]") - 1 - (InStr(CommandOutput, "[")))
Else
Err.Raise ERR_WRONG_URL
End If
RunShell = IPAddress
End Function

Есть ли лучший способ получить IP? адрес из домена менее чем за пару секунд?

Answer 1

Этот подход относительно быстрый, однако время выполнения будет очень сильно зависеть от соединения между вами и сервером, на который вы пытаетесь попасть. Я нажимаю Google / Microsoft менее чем за секунду.

Я заключил большую часть этого в простую функцию. Просто передайте имя хоста, по которому вы пытаетесь попасть, и он вернет IP-адрес.

Функция

Option Explicit

Public Function GetHostIPAddress(ByVal HostName As String) As String
  Dim Pinger       As Object
  Dim PingResult   As Variant

  Set Pinger = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & HostName & "'")

  For Each PingResult In Pinger

    If Not (IsNull(PingResult.StatusCode) Or PingResult.StatusCode <> 0) Then
        GetHostIPAddress = PingResult.ProtocolAddress
        Exit Function
    End If

  Next
End Function

Пример использования:

Sub ExampleCall()
    Dim t As Double
    t = Timer
    Debug.Print "pinging: " & GetHostIPAddress("www.google.com") & " took " & Timer - t & " seconds"
End Sub