CODEWITHSUNDEEP
vbaexceltimer
Sam WB
Sam WB

Reputation: 195

Excel VBA: How to implement timer to check for code timeout

I have some code that runs on workbook open that uses a form to request that the user select the drive to which a shared directory is mapped.

This is because the workbook uses VBA code to retrieve and save data to a shared workbook located in this shared directory, but the local drive changes by user, so they need to select it.

The problem I've run into occurs when the user has mapped multiple shared directories to their computer and thus have multiple drives... ex: 1 directory is on drive G: and the other is on X:.

If they select the drive for the shared directory in which the workbook resides, there is no problem. However, if they accidentally choose the drive for the other shared directory, the code hangs.

I have a loop setup that checks to see they've chosen the correct drive... IE: If they chose A: (a non-existent drive in my example), then the code will note that they chose the incorrect drive and prompt them again.

However, instead of creating an error when another shared directory is chosen, the code just hangs.

In the below code, cell AD3 on sheet one contains true or false (gets set to false in the beginning of the sub). It gets set to true if they've chosen correct drive as Module6.PipelineRefresh will no longer cause an error (this sub attempts to open the workbook in the shared drive... and if the chosen drive is incorrect it obviously returns an error)

Codes is as below:

Do While Sheet1.Range("ad3") = False
    On Error Resume Next
        Call Module6.PipelineRefresh  '~~ I'm guessing the code hangs here.  Instead of returning an error immediately, as it would if they simply chose a non-existant drive, it appears to get stuck trying to open the workbook, even though it's not located in the shared directory they've selected.
    If Err.Number = 0 Then
        Sheet1.Range("ad3") = True
        Err.Clear
    Else
        MsgBox "Invalid Network Drive."
        DriverSelectForm.Show
        Err.Clear
    End If
Loop

If anyone knows how to implement a timer so I can shutdown the code after some amount of time, that'd be great.

Alternatively, if you know how to get around this error, that'd also be great!

EDIT as per comment:

This is the specific code in Module6.PipelineRefresh that hangs. The DriverSelectForm (shown above) amends the value in cell o1 to the chosen drive string (ie: X:)

Dim xlo As New Excel.Application
Dim xlw As New Excel.Workbook
Dim xlz As String
xlz = Sheet1.Range("o1").Value & "\Region Planning\Created Pipeline.xlsx"
Dim WS As Worksheet
Dim PT As PivotTable

Application.DisplayAlerts = False
Set xlw = xlo.Workbooks.Open(xlz)
Application.DisplayAlerts = True

Note: As stated above, if the user selects a non-existent directory, the above code returns an error immediately because it cannot open the file... if they have a shared directory mapped to the chosen drive (but it's the wrong directory), the code will hang and does not appear to return an error.

Upvotes: 1

Views: 6499

Answers (2)

Aleksey F.
Aleksey F.

Reputation: 761

The solution to stop some code by timer. The code must be placed in a module.

Private m_stop As Boolean
Sub stop_timer(p_start_time As Variant)
  Application.OnTime p_start_time, "stop_loop"
End Sub
Sub signal_timer(p_start_time As Variant)
  Application.OnTime p_start_time, "signal_in_loop"
End Sub
Sub test_loop()
  Dim v_cntr As Long
  m_stop = False
  v_cntr = 0
  stop_timer Now + TimeValue("00:00:05")
  signal_in_loop
  While Not m_stop
    v_cntr = v_cntr + 1
    DoEvents
  Wend
  Debug.Print "Counter:", v_cntr
End Sub
Sub stop_loop()
  m_stop = True
End Sub
Sub signal_in_loop()
  Debug.Print "timer:", Timer
  If Not m_stop Then
    signal_timer Now + TimeValue("00:00:01")
  End If
End Sub

Output:

timer:         50191.92 
timer:         50192 
timer:         50193 
timer:         50194 
timer:         50195 
timer:         50196 
Counter:       67062 
timer:         50197.05

m_stop controls the loop. DoEvents calls event handlers such as stop_loop and signal_in_loop as defered procedures.

Upvotes: 1

Sam WB
Sam WB

Reputation: 195

I've answered my own question by working around the problem. Instead of checking that the user has selected the correct drive letter, I am now using the CreatObject function to find the drive letter associated with the drive name (as drive name will not change).

Example code for this:

Dim objDrv      As Object
Dim DriveLtr      As String

For Each objDrv In CreateObject("Scripting.FileSystemObject").Drives
    If objDrv.ShareName = "Shared Drive Name" Then
        DriveLtr = objDrv.DriveLetter
    End If
Next

If Not DriveLtr = "" Then
    MsgBox DriveLtr & ":"
Else
    MsgBox "Not Found"
End If
Set objDrv = Nothing

Upvotes: 2

Related Questions