retrieve Hostname from IP address using VBA

[StuartKStout]

Hi

a Colleague wrote the below and has now left the company, I now need to expand the code so in cell.offset (0, 4) it will display the FQDN, is this possible?

The IPs start at Cell 'A2' and generally go down to row 254

Thanks in advance
Stuart

Sub PingTest()


  Dim Cell As Range
  Dim colPings As Object, objPing As Object, strQuery As String
  Dim Rng As Range
  Dim RngEnd As Range
  Dim Wks As Worksheet
  
    Set Wks = ActiveSheet
    
    Set Rng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
    
    For Each Cell In Rng
    
      'Define the WMI query
       strQuery = "SELECT * FROM Win32_PingStatus WHERE Address = '" & Cell & "'"


      'Run the WMI query
       Set colPings = GetObject("winmgmts://./root/cimv2").ExecQuery(strQuery)


      'Translate the query results to either True or False
       For Each objPing In colPings
         If Not objPing Is Nothing Then
            Cell.Offset(0, 1) = objPing.ProtocolAddress
            Cell.Offset(0, 2) = objPing.ResponseTime & " ms"
            Cell.Offset(0, 3) = GetPingStatus(objPing.StatusCode)
            'Cell.Offset(0, 4) = objPing.ResolveAddressName.Value
            
 Exit For
            
         End If
       Next objPing
     
     Next Cell
    
End Sub

 

[GR00007]

This is incorporating a routine found on Geekality:

Sub PingTest()    Dim Cell As Range
    Dim colPings As Object, objPing As Object, strQuery As String
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Wks As Worksheet
    vUserProf = Environ("USERPROFILE")
    vDir = vUserProf & "\Downloads\"
    TmpFile = vDir & "TmpFile.txt"
    Dim oFSO As Object
    Dim oShell As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oShell = CreateObject("Wscript.Shell")
    Dim waitOnReturn As Boolean: waitOnReturn = True
    Dim windowStyle As Integer: windowStyle = 1
    Set Wks = ActiveSheet
    Set Rng = Wks.Range("A2")
    Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
    If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
        For Each Cell In Rng
        'Define the WMI query
        strQuery = "SELECT * FROM Win32_PingStatus WHERE Address = '" & Cell & "'"
        'Run the WMI query
        Set colPings = GetObject("winmgmts://./root/cimv2").ExecQuery(strQuery)
        'Run CMD to obtain Domain Name
        vx = "cmd.exe /c nslookup " & Cell & " > " & TmpFile
        oShell.Run "cmd.exe /c nslookup " & Cell & " > " & TmpFile, windowStyle, waitOnReturn
        TmpTxt = ""
        Set oTempWk = oFSO.OpenTextFile(TmpFile, 1)
        Do While oTempWk.AtEndOfStream <> True
            vx = Trim(oTempWk.Readline)
            If "Name:" = Left(vx, 5) Then TmpTxt = ""
            TmpTxt = TmpTxt & vx
        Loop
        oTempWk.Close
        oFSO.DeleteFile (TmpFile)
        If TmpTxt = "" Or InStr(1, TmpTxt, "Name:", vbTextCompare) = 0 Then
            DomainName = "None found"
        Else
            ix1 = InStr(1, TmpTxt, "Name:", vbTextCompare) + 5
            ix2 = InStr(1, TmpTxt, "Address", vbTextCompare)
            DomainName = Trim(Mid(TmpTxt, ix1, ix2 - ix1))
        End If
        'Translate the query results to either True or False
        For Each objPing In colPings
            If Not objPing Is Nothing Then
            Cell.Offset(0, 1) = objPing.ProtocolAddress
            Cell.Offset(0, 2) = objPing.ResponseTime & " ms"
            If objPing.PrimaryAddressResolutionStatus > 0 Then
                Cell.Offset(0, 3) = GetPingStatus(objPing.PrimaryAddressResolutionStatus)
            Else
                Cell.Offset(0, 3) = GetPingStatus(objPing.StatusCode)
            End If
            Cell.Offset(0, 4) = DomainName
            'Cell.Offset(0, 4) = objPing.ResolveAddressName.Value
            Exit For
            End If
        Next objPing
    Next Cell
End Sub
Function GetPingStatus(StatCd As String)
    Select Case StatCd
    Case 0: strResult = "Connected"
    Case 11001: strResult = "Buffer too small"
    Case 11002: strResult = "Destination net unreachable"
    Case 11003: strResult = "Destination host unreachable"
    Case 11004: strResult = "Destination protocol unreachable"
    Case 11005: strResult = "Destination port unreachable"
    Case 11006: strResult = "No resources"
    Case 11007: strResult = "Bad option"
    Case 11008: strResult = "Hardware error"
    Case 11009: strResult = "Packet too big"
    Case 11010: strResult = "Request timed out"
    Case 11011: strResult = "Bad request"
    Case 11012: strResult = "Bad route"
    Case 11013: strResult = "Time-To-Live (TTL) expired transit"
    Case 11014: strResult = "Time-To-Live (TTL) expired reassembly"
    Case 11015: strResult = "Parameter problem"
    Case 11016: strResult = "Source quench"
    Case 11017: strResult = "Option too big"
    Case 11018: strResult = "Bad destination"
    Case 11032: strResult = "Negotiating IPSEC"
    Case 11050: strResult = "General failure"
    Case Else: strResult = "Unknown host"
    End Select
    GetPingStatus = strResult
End Function

 

[StuartKStout]

Perfect, Thank you.