Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

VBA in Excel for the Network checking

Posted on 2014-02-07
1
Medium Priority
?
641 Views
Last Modified: 2014-02-07
I'm working on a project to export data from an Excel workbook to SAS Database.  Before exporting, I need check if there is internet connection.  I got the following VBA code from a co-worker, which is checking if our company's server for the company inside web page is available.  We found occasionally we got fails for the internet connection even from a PC that is wired to company's network.  Does that mean the company internet is not stable or the code below has some issues?  Any advices are very appreciated.  



Option Explicit
Public Const SERVER As String = "thstapw2-inside.prod.travp.net" '-- the current insidepage host (http://inside.here.travp.net/intraHome/index.aspx)


Public Function UserHasAccess() As Boolean
    Dim lngPing As Long
    Dim blnAnswer As Boolean

    On Error GoTo PROC_ERR
    '* check if user connected to Travelers Network
    lngPing = InNetwork(SERVER)
    If lngPing = 0 Then
        blnAnswer = True
        GoTo PROC_EXIT
    Else
        blnAnswer = False
    End If
    GoTo PROC_EXIT

PROC_ERR:
    If (Err.Number <> 0) Then
        Err.Clear
    End If
    blnAnswer = False

PROC_EXIT:
    UserHasAccess = blnAnswer
End Function


Private Function InNetwork(ByVal strServer As String, Optional ByVal lngPings As Long, Optional ByVal lngTimeOut As Long) As Long
    Dim lngResult As Long
    Dim objWS As Object

    On Error GoTo PROC_ERR
    If lngPings = 0 Then lngPings = 1
    If lngTimeOut = 0 Then lngTimeOut = 250
    Set objWS = CreateObject("WScript.Shell")
    With objWS
      lngResult = .Run("%comspec% /c ping.exe -n " & lngPings & " -w " & lngTimeOut _
           & " " & strServer & " | find ""TTL="" > nul 2>&1", 0, True)
    End With
    GoTo PROC_EXIT

PROC_ERR:
    If (Err.Number <> 0) Then
        Err.Clear
        lngResult = -1
    End If

PROC_EXIT:
    Set objWS = Nothing
    InNetwork = lngResult
End Function
0
Comment
Question by:jjxia2001
1 Comment
 
LVL 19

Accepted Solution

by:
regmigrant earned 2000 total points
ID: 39842473
I think the execution of the ping is taking longer in some cases than in others - there could be many reasons - but vba doesn't wait for the response so returns a fail.

There's a routine from one of the other experts called 'shell and wait' that executes the command and waits for a response.

Option Explicit
Option Compare Text

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' modShellAndWait
' By Chip Pearson, chip@cpearson.com, www.cpearson.com
' This page on the web site: www.cpearson.com/Excel/ShellAndWait.aspx
' 9-September-2008
'
' This module contains code for the ShellAndWait function that will Shell to a process
' and wait for that process to end before returning to the caller.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" ( _
    ByVal hHandle As Long, _
    ByVal dwMilliseconds As Long) As Long

Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" ( _
    ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long

Private Declare PtrSafe Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long

Private Const SYNCHRONIZE = &H100000

Public Enum ShellAndWaitResult
    success = 0
    Failure = 1
    Timeout = 2
    InvalidParameter = 3
    SysWaitAbandoned = 4
    UserWaitAbandoned = 5
    UserBreak = 6
End Enum

Public Enum ActionOnBreak
    IgnoreBreak = 0
    AbandonWait = 1
    PromptUser = 2
End Enum
Option Private Module
Private Const STATUS_ABANDONED_WAIT_0 As Long = &H80
Private Const STATUS_WAIT_0 As Long = &H0
Private Const WAIT_ABANDONED As Long = (STATUS_ABANDONED_WAIT_0 + 0)
Private Const WAIT_OBJECT_0 As Long = (STATUS_WAIT_0 + 0)
Private Const WAIT_TIMEOUT As Long = 258&
Private Const WAIT_FAILED As Long = &HFFFFFFFF
Private Const WAIT_INFINITE = -1&


Public Function ShellAndWait(ShellCommand As String, _
                    TimeOutMs As Long, _
                    ShellWindowState As VbAppWinStyle, _
                    BreakKey As ActionOnBreak) As ShellAndWaitResult
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShellAndWait
'
' This function calls Shell and passes to it the command text in ShellCommand. The function
' then waits for TimeOutMs (in milliseconds) to expire.
'
'   Parameters:
'       ShellCommand
'           is the command text to pass to the Shell function.
'
'       TimeOutMs
'           is the number of milliseconds to wait for the shell'd program to wait. If the
'           shell'd program terminates before TimeOutMs has expired, the function returns
'           ShellAndWaitResult.Success = 0. If TimeOutMs expires before the shell'd program
'           terminates, the return value is ShellAndWaitResult.TimeOut = 2.
'
'       ShellWindowState
'           is an item in VbAppWinStyle specifying the window state for the shell'd program.
'
'       BreakKey
'           is an item in ActionOnBreak indicating how to handle the application's cancel key
'           (Ctrl Break). If BreakKey is ActionOnBreak.AbandonWait and the user cancels, the
'           wait is abandoned and the result is ShellAndWaitResult.UserWaitAbandoned = 5.
'           If BreakKey is ActionOnBreak.IgnoreBreak, the cancel key is ignored. If
'           BreakKey is ActionOnBreak.PromptUser, the user is given a ?Continue? message. If the
'           user selects "do not continue", the function returns ShellAndWaitResult.UserBreak = 6.
'           If the user selects "continue", the wait is continued.
'
'   Return values:
'            ShellAndWaitResult.Success = 0
'               indicates the the process completed successfully.
'            ShellAndWaitResult.Failure = 1
'               indicates that the Wait operation failed due to a Windows error.
'            ShellAndWaitResult.TimeOut = 2
'               indicates that the TimeOutMs interval timed out the Wait.
'            ShellAndWaitResult.InvalidParameter = 3
'               indicates that an invalid value was passed to the procedure.
'            ShellAndWaitResult.SysWaitAbandoned = 4
'               indicates that the system abandoned the wait.
'            ShellAndWaitResult.UserWaitAbandoned = 5
'               indicates that the user abandoned the wait via the cancel key (Ctrl+Break).
'               This happens only if BreakKey is set to ActionOnBreak.AbandonWait.
'            ShellAndWaitResult.UserBreak = 6
'               indicates that the user broke out of the wait after being prompted with
'               a ?Continue message. This happens only if BreakKey is set to
'               ActionOnBreak.PromptUser.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim TaskID As Long
Dim ProcHandle As Long
Dim WaitRes As Long
Dim Ms As Long
Dim MsgRes As VbMsgBoxResult
Dim SaveCancelKey As XlEnableCancelKey
Dim ElapsedTime As Long
Dim Quit As Boolean
Const ERR_BREAK_KEY = 18
Const DEFAULT_POLL_INTERVAL = 500
Dim updater As Long
Dim updatewait As Long
updatesOn
Application.StatusBar = "Waiting for directory - this may take a while on network or sharepoint..."
DoEvents
updatesOff
updatewait = 10
updater = 0
errloc = "In shell and wait"
If Trim(ShellCommand) = vbNullString Then
    ShellAndWait = ShellAndWaitResult.InvalidParameter
    Exit Function
End If

If TimeOutMs < 0 Then
    ShellAndWait = ShellAndWaitResult.InvalidParameter
    Exit Function
ElseIf TimeOutMs = 0 Then
    Ms = WAIT_INFINITE
Else
    Ms = TimeOutMs
End If

Select Case BreakKey
    Case AbandonWait, IgnoreBreak, PromptUser
        ' valid
    Case Else
        ShellAndWait = ShellAndWaitResult.InvalidParameter
        Exit Function
End Select

Select Case ShellWindowState
    Case vbHide, vbMaximizedFocus, vbMinimizedFocus, vbMinimizedNoFocus, vbNormalFocus, vbNormalNoFocus
        ' valid
    Case Else
        ShellAndWait = ShellAndWaitResult.InvalidParameter
        Exit Function
End Select

On Error Resume Next
Err.Clear
TaskID = Shell(ShellCommand, ShellWindowState)
If (Err.Number <> 0) Or (TaskID = 0) Then
    ShellAndWait = ShellAndWaitResult.Failure
    Exit Function
End If

ProcHandle = OpenProcess(SYNCHRONIZE, False, TaskID)
If ProcHandle = 0 Then
    ShellAndWait = ShellAndWaitResult.Failure
    Exit Function
End If

On Error GoTo ErrH:
SaveCancelKey = Application.EnableCancelKey
Application.EnableCancelKey = xlErrorHandler
WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
Do Until WaitRes = WAIT_OBJECT_0
    'DoEvents
    updater = updater + 1
    If updater Mod updatewait = 0 Then
        updatesOn
        Application.StatusBar = "getting directory: " & updater
        DoEvents
        updatesOff
    End If
    Select Case WaitRes
        Case WAIT_ABANDONED
            ' Windows abandoned the wait
            ShellAndWait = ShellAndWaitResult.SysWaitAbandoned
            Exit Do
        Case WAIT_OBJECT_0
            ' Successful completion
            ShellAndWait = ShellAndWaitResult.success
            Exit Do
        Case WAIT_FAILED
            ' attach failed
            ShellAndWait = ShellAndWaitResult.Failure
            Exit Do
        Case WAIT_TIMEOUT
            ' Wait timed out. Here, this time out is on DEFAULT_POLL_INTERVAL.
            ' See if ElapsedTime is greater than the user specified wait
            ' time out. If we have exceed that, get out with a TimeOut status.
            ' Otherwise, reissue as wait and continue.
            ElapsedTime = ElapsedTime + DEFAULT_POLL_INTERVAL
            If Ms > 0 Then
                ' user specified timeout
                If ElapsedTime > Ms Then
                    ShellAndWait = ShellAndWaitResult.Timeout
                    Exit Do
                Else
                    ' user defined timeout has not expired.
                End If
            Else
                ' infinite wait -- do nothing
            End If
            ' reissue the Wait on ProcHandle
            WaitRes = WaitForSingleObject(ProcHandle, DEFAULT_POLL_INTERVAL)
            
        Case Else
            ' unknown result, assume failure
            ShellAndWait = ShellAndWaitResult.Failure
            Exit Do
            Quit = True
    End Select
Loop

CloseHandle ProcHandle
Application.EnableCancelKey = SaveCancelKey
Exit Function

ErrH:
Debug.Print "ErrH: Cancel: " & Application.EnableCancelKey
updatesOn
Application.StatusBar = "Interrupted...."

If Err.Number = ERR_BREAK_KEY Then
    If BreakKey = ActionOnBreak.AbandonWait Then
        CloseHandle ProcHandle
        ShellAndWait = ShellAndWaitResult.UserWaitAbandoned
        Exit Function
    ElseIf BreakKey = ActionOnBreak.IgnoreBreak Then
        Err.Clear
        updatesOff
        Resume
    ElseIf BreakKey = ActionOnBreak.PromptUser Then
        MsgRes = MsgBox("User Process Break." & vbCrLf & _
            "Continue to wait?", vbYesNo)
        If MsgRes = vbNo Then
            CloseHandle ProcHandle
            ShellAndWait = ShellAndWaitResult.UserBreak
            Application.EnableCancelKey = SaveCancelKey
        Else
            Err.Clear
            Application.StatusBar = "resumed..."
            updatesOff
            Resume Next
        End If
    Else
        CloseHandle ProcHandle
        Application.EnableCancelKey = SaveCancelKey
        ShellAndWait = ShellAndWaitResult.Failure
    End If
Else
    ' some other error. assume failure
    CloseHandle ProcHandle
    ShellAndWait = ShellAndWaitResult.Failure
    Application.StatusBar = "failed to get directory"
End If

Application.EnableCancelKey = SaveCancelKey

End Function

Open in new window

0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

New style of hardware planning for Microsoft Exchange server.
Quickbooks hosting can do wonders to your enterprise but considering the points elaborated in the article which will help you to better analyze the outcomes. So scan your business, its needs and then move to the new world of limitless benefits.
Have you created a query with information for a calendar? ... and then, abra-cadabra, the calendar is done?! I am going to show you how to make that happen. Visualize your data!  ... really see it To use the code to create a calendar from a q…
This lesson discusses how to use a Mainform + Subforms in Microsoft Access to find and enter data for payments on orders. The sample data comes from a custom shop that builds and sells movable storage structures that are delivered to your property. …

886 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question