Excel VBA:如何实现计时器检查代码超时

Question

我有一些在工作簿打开时运行的代码，它使用表单请求用户选择共享目录映射到的驱动器。

这是因为工作簿使用VBA代码来检索和保存数据到位于此共享目录中的共享工作簿，但是本地驱动器因用户而异，因此需要选择它。

我遇到的问题发生在用户将多个共享目录映射到他们的计算机并因此有多个驱动器时…例如:1个目录在G盘，另一个在X盘。

如果他们为工作簿所在的共享目录选择驱动器，则没有问题。但是，如果他们不小心选择了另一个共享目录的驱动器，代码将挂起。

我有一个循环设置，检查他们是否选择了正确的驱动器…IE:如果他们选择了A:(在我的例子中是一个不存在的驱动器)，那么代码会注意到他们选择了错误的驱动器并再次提示他们。

但是，当选择另一个共享目录时，不会产生错误，代码只是挂起。

在下面的代码中，工作表1上的单元格AD3包含true或false(在子开头设置为false)。如果他们选择了正确的驱动器作为Module6，则将其设置为true。pipelinerrefresh将不再导致错误(此子尝试打开共享驱动器中的工作簿…)如果选择的驱动器不正确，它显然返回一个错误)

代码如下:

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

如果有人知道如何实现定时器，所以我可以关闭一些时间后的代码，那将是伟大的。

或者，如果你知道如何绕过这个错误，那也很棒!

按注释编辑:

这是Module6.PipelineRefresh中挂起的特定代码。DriverSelectForm(如上所示)将单元格o1中的值修正为所选驱动器字符串(即:X:)

Dim xlo As New Excel.Application
Dim xlw As New Excel.Workbook
Dim xlz As String
xlz = Sheet1.Range("o1").Value & "Region PlanningCreated Pipeline.xlsx"
Dim WS As Worksheet
Dim PT As PivotTable
Application.DisplayAlerts = False
Set xlw = xlo.Workbooks.Open(xlz)
Application.DisplayAlerts = True

注意:如上所述，如果用户选择了一个不存在的目录，上面的代码会立即返回一个错误，因为它无法打开文件…如果它们有一个共享目录映射到所选的驱动器(但它是错误的目录)，则代码将挂起并且似乎不会返回错误。

Answer 1

我已经通过解决问题回答了我自己的问题。而不是检查用户是否选择了正确的驱动器号，我现在使用CreatObject功能来查找与驱动器名称相关的驱动器号(因为驱动器名称不会更改)。

示例代码:

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

Answer 2

通过定时器停止某些代码的解决方案。代码必须放在模块中。

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

输出:

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

m_stop控制循环。DoEvents调用事件处理程序，如stop_loop和signal_in_loop作为延迟过程。