CODEWITHSUNDEEP
vbams-accessip
Mark Pelletier
Mark Pelletier

Reputation: 1359

VBA - Determine if IP is Reachable

I have a collection of users US, India, and Remote via VPN. I am using a DSN-less approach to link to remote tables in my Access DB App.

I need an efficient method to determine if the user-selected IP is reachable (called "myIP").

My current approach PINGS myIP, but opens a pesky CMD window and takes several seconds to resolve the status.

SystemReachable (myIP)

If InStr(myStatus, "Reply") > 0 Then
    ' MsgBox "IP is Confirmed Reachable"
Else
    MsgBox "[" & myIP & "] is not Reachable" & vbCrLf & vbCrLf & Confirm your selected location, or VPN is active."
    Exit Sub
End If

''''''''''''''''''''''''''''

Function SystemReachable(ByVal ComputerName As String)
Dim oShell, oExec As Variant
Dim strText, strCmd As String

strText = ""
strCmd = "ping -n 3 -w 1000 " & ComputerName

Set oShell = CreateObject("WScript.Shell")
Set oExec = oShell.Exec(strCmd)

Do While Not oExec.StdOut.AtEndOfStream
    strText = oExec.StdOut.ReadLine()
    If InStr(strText, "Reply") > 0 Then
        myStatus = strText
        Exit Do
    Else
        myStatus = ""
    End If
Loop

End Function

Is there a better/faster way to determine the status/reachability of "myIP"?

Thanks!

Upvotes: 2

Views: 13134

Answers (3)

RunningWild
RunningWild

Reputation: 1

Based on Steven Ding's solution, I shortened to a 1-liner (because I simply love overloaded short functions):

Function PingOk(Ip As String) As Boolean
  PingOk = (0 = CreateObject("Wscript.Shell").Run("%SystemRoot%\system32\ping.exe -n 1 -l 1 -w 5000 " & Ip, 0, True))
End Function

Upvotes: 0

Steven Ding
Steven Ding

Reputation: 61

Doing so with a temp file doesn't seem a good solution, especially when SSD is used.

ShellObject.Run when you pass TRUE as the 3rd parameter, it returns the command return value.

For "ping", it's set to 0 when the host is reachable, and set to others if it's not reachable or any error happens. So you can use below to quickly decide whether the destination is reachable:

    Dim strCommand
    Dim iRet

    strCommand = "%SystemRoot%\system32\ping.exe -n 1 -l 1 -w 500 " & myIP
    iRet = fShellRun(strCommand)

    If iRet <> 0 Then
        MsgBox "Not Connected"
    Else
        MsgBox "Connected!"
    End If

    Function fShellRun(sCommandStringToExecute)

        ' This function will accept a string as a DOS command to execute.
        ' It will then execute the command in a shell, and returns the command 
        ' return code to the caller. 

        ' "myIP" is a user-selected global variable

        Dim oShellObject

        Set oShellObject = CreateObject("Wscript.Shell")

        On Error Resume Next
        fShellRun = oShellObject.Run(sCommandStringToExecute, 0, TRUE)

    End Function

Upvotes: 1

Mark Pelletier
Mark Pelletier

Reputation: 1359

Found a very workable and silent approach:

Dim strCommand as string
Dim strPing As String

strCommand = "%ComSpec% /C %SystemRoot%\system32\ping.exe -n 1 -w 500 " & myIP & " | " & "%SystemRoot%\system32\find.exe /i " & Chr(34) & "TTL=" & Chr(34)
strPing = fShellRun(strCommand)

If strPing = "" Then
    MsgBox "Not Connected"
Else
    MsgBox "Connected!"
End If

'''''''''''''''''''''''''''

Function fShellRun(sCommandStringToExecute)

' This function will accept a string as a DOS command to execute.
' It will then execute the command in a shell, and capture the output into a file.
' That file is then read in and its contents are returned as the value the function returns.

' "myIP" is a user-selected global variable

Dim oShellObject, oFileSystemObject, sShellRndTmpFile
Dim oShellOutputFileToRead, iErr

Set oShellObject = CreateObject("Wscript.Shell")
Set oFileSystemObject = CreateObject("Scripting.FileSystemObject")

    sShellRndTmpFile = oShellObject.ExpandEnvironmentStrings("%temp%") & oFileSystemObject.GetTempName
    On Error Resume Next
    oShellObject.Run sCommandStringToExecute & " > " & sShellRndTmpFile, 0, True
    iErr = Err.Number

    On Error GoTo 0
    If iErr <> 0 Then
        fShellRun = ""
        Exit Function
    End If

    On Error GoTo err_skip
    fShellRun = oFileSystemObject.OpenTextFile(sShellRndTmpFile, 1).ReadAll
    oFileSystemObject.DeleteFile sShellRndTmpFile, True

Exit Function

err_skip:
    fShellRun = ""
    oFileSystemObject.DeleteFile sShellRndTmpFile, True


End Function

Upvotes: 3

Related Questions