用于从域获取IP地址的Excel VBA

Question

我正在尝试为MS Excel编写VB脚本以从域中获取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