不活动后自动关闭工作簿

Question

我创建了一个宏，在一段时间不活动后关闭WB。如果我手动打开文件，它会工作得很好，但如果我使用另一个WB中的另一个宏打开文件，它将在设置的非活动时间后自动关闭。我用于自动关闭它的代码是：

当前工作簿模块：

Private Sub Workbook_BeforeClose(Cancel As Boolean) 
    stop_Countdown 
ThisWorkbook.Save 
End Sub 
Private Sub Workbook_Open() 
    start_Countdown 
    End Sub 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 
    stop_Countdown 
    start_Countdown 
    End Sub 
Private Sub Workbook_SheetCalculate(ByVal Sh As Object) 
    stop_Countdown 
    start_Countdown 
End Sub 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, _ 
    ByVal Target As Excel.Range) 
    stop_Countdown 
    start_Countdown 
End Sub 

常规模块：

Option Explicit 
Public Close_Time As Date 
Sub start_Countdown() 
    Close_Time = Now() + TimeValue("00:00:10") 
    Application.OnTime Close_Time, "close_WB" 
    End Sub 
Sub stop_Countdown() 
    Application.OnTime Close_Time, "close_WB", , False 
    End Sub 
Sub close_wb() 
    ThisWorkbook.Close True 
    End Sub 

其他宏的代码：

Sub Answer_Quote() 

Worksheets("UI RM").Protect DrawingObjects:=False, Contents:=False, Scenarios:=False, Password:="045" 

Dim wBook As Workbook 
    On Error Resume Next 
    Set wBook = Workbooks("Base de Datos Cotizaciones Shared.xlsb") 

    If wBook Is Nothing Then 'Not open 
      Set wBook = Nothing 
      On Error GoTo 0 
    Else 'It is open 
      wBook.Close SaveChanges:=False 
      Set wBook = Nothing 
      On Error GoTo 0 
    End If 

Set wb4 = ActiveWorkbook 
Range("AM7").Calculate 
Range("K26:K28").Calculate 
Dim arreglo(4) As Variant 
arreglo(0) = Range("hour_sent").Value 
arreglo(1) = Range("day_sent").Value 
arreglo(2) = Range("respuesta").Value 
arreglo(3) = Range("UsernameRM").Value 

Dim Findwhat As String 
Dim c, d, multirange As Range 
Findwhat = Range("F11").Text 

    Dim contador As Integer 
    contador = 0 
    While (IsFileOpen("\\3kusmiafs02\CARPETA COMERCIAL\Cotizaciones\Base de Datos Cotizaciones Shared.xlsb") And contador < 4) 
     contador = contador + 1 
     Application.Wait (Now + TimeValue("00:00:03")) 
    Wend 

    If contador = 4 Then 
    MsgBox "La base de datos esta siendo utilizada por otro usuario. Por favor vuelva a intentarlo", vbExclamation, "Proceso cancelado" 
    Exit Sub 
    End If 

Application.ScreenUpdating = False 
Dim iStatus As Long 
Err.Clear 
On Error Resume Next 
Set wb2 = Workbooks("Base de Datos Cotizaciones Shared.xlsb") 
iStatus = Err 
On Error GoTo 0 
If iStatus Then 'workbook isn't open 
Workbooks.Open filename:="\\3kusmiafs02\CARPETA COMERCIAL\Cotizaciones\Base de Datos Cotizaciones Shared.xlsb" 
Else 
'workbook is open 
wb2.Activate 
End If 

On Error GoTo errHandler: 

'Copy Hour Sent 
Worksheets("Data").Activate 
Set c = Range("A:A").Find(Findwhat, LookIn:=xlValues) 
For j = 1 To 3 
    c.Offset(0, 17 + j) = arreglo(j - 1) 
Next j 
c.Offset(0, 29) = arreglo(3) 


'Save Database 
Workbooks("Base de Datos Cotizaciones Shared.xlsb").Save 
Workbooks("Base de Datos Cotizaciones Shared.xlsb").Close 

    'Step-Back into User Interface 
    wb4.Activate 
    Worksheets("UI RM").Activate 

    'Send E-Mail 

    'Working in 2000-2010 
    Dim Source As Range 
    Dim Dest As Workbook 
    Dim wb As Workbook 
    Dim TempFilePath As String 
    Dim TempFileName As String 
    Dim FileExtStr As String 
    Dim FileFormatNum As Long 
    Dim response As Variant 


    'Mail recipients 

    Dim mail_recipients(3) As String 

    'mail_recipients(1) = Range("email").Value 
    'mail_recipients(2) = "mail" 
    mail_recipients(3) = "mail2" 


    'Source Set/Range selection 

    Set Source = Nothing 
    On Error Resume Next 

    Worksheets.Add(After:=Worksheets("Interline Costs")).Name = "Quote Snap" 

    'copy temp info 
    Worksheets("UI RM").Activate 
    Range("B7:G31").SpecialCells(xlCellTypeVisible).Select 
    Application.CutCopyMode = False 
    Selection.Copy 
    Worksheets("quote snap").Activate 
    Range("b2").Select 
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 
    ActiveSheet.Paste 

    'copy temp dims 
    Worksheets("UI rm").Activate 
    Range("I21:s33").SpecialCells(xlCellTypeVisible).Select 
     Selection.Copy 
    Worksheets("Quote Snap").Activate 
    Range("H3").Select 
    ActiveSheet.Paste 
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, _ 
     SkipBlanks:=False, Transpose:=False 
    Columns("j:j").Select 
    Selection.ColumnWidth = 12 

    'select temp sheet 
    Range("A1:V600").Select 


Set Source = Selection.SpecialCells(xlCellTypeVisible) 


    Set wb = ActiveWorkbook 
    Set Dest = Workbooks.Add(xlWBATWorksheet) 

    Source.Copy 
    With Dest.Sheets(1) 
     .Cells.Interior.Pattern = xlSolid 
     .Cells.Interior.PatternColorIndex = xlAutomatic 
     .Cells.Interior.ThemeColor = xlThemeColorDark1 
     .Cells.Interior.TintAndShade = 0 
     .Cells.Interior.PatternTintAndShade = 0 
     .Cells(1).PasteSpecial Paste:=8 
     .Cells(1).PasteSpecial Paste:=xlPasteValues 
     .Cells(1).PasteSpecial Paste:=xlPasteFormats 
     .Cells(1).Select 
     Application.CutCopyMode = False 

    End With 

    TempFilePath = Environ$("temp") & "\" 
    TempFileName = "Response to Quote #" & wb4.Worksheets("UI RM").Range("F11") 

    If Val(Application.Version) < 12 Then 
     'You use Excel 2000-2003 
     FileExtStr = ".xls": FileFormatNum = -4143 
    Else 
     'You use Excel 2007-2010 
     FileExtStr = ".xlsx": FileFormatNum = 51 
    End If 
    With Dest 
     .SaveAs TempFilePath & TempFileName & FileExtStr, _ 
       FileFormat:=FileFormatNum 
     On Error Resume Next 
     For i = 1 To 3 
      .SendMail Recipients:=mail_recipients, _ 
        Subject:="Response to Quote #" & wb4.Worksheets("UI RM").Range("quote_num") & " " & wb4.Worksheets("UI RM").Range("client") & " " & wb4.Worksheets("UI RM").Range("destination") & " " & wb4.Worksheets("UI RM").Range("total_KGS") & " KGS" 

      If Err.Number = 0 Then Exit For 
     Next i 
     On Error GoTo 0 
     .Close SaveChanges:=False 
    End With 

    'Delete the file you have send 
    Kill TempFilePath & TempFileName & FileExtStr 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
    Application.DisplayAlerts = False 
    wb4.Worksheets("quote snap").Delete 
    Application.DisplayAlerts = True 


MsgBox "Proceso Terminado" 

wb4.Sheets("UI RM").Range("limpiar").ClearContents 
wb4.Sheets("UI RM").Range("F29").ClearContents 
wb4.Sheets("UI RM").Range("E43:I80").ClearContents 

    'Starting Point 
    wb4.Worksheets("UI RM").Activate 
    Range("F11").Select 

Application.Calculation = xlCalculationManual 

Worksheets("UI RM").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="045" 


Exit Sub 

errHandler: 

Dim wBook1 As Workbook 
    On Error Resume Next 
    Set wBook1 = Workbooks("Base de Datos Cotizaciones Shared.xlsb") 

    If wBook1 Is Nothing Then 'Not open 
      Set wBook1 = Nothing 
      On Error GoTo 0 
    Else 'It is open 
      wBook1.Close SaveChanges:=False 
      Set wBook1 = Nothing 
      On Error GoTo 0 
    End If 
MsgBox "Hubo un error", vbExclamation, "Error" 

End Sub 

不限想法？

Answer 1

正如Susilo在评论中指出的那样，该问题必须不是自动关闭代码本身，因为它的工作原理。那个“别的东西”可能是Answer_Quote()的代码，坦率地说是一个大混乱。我想提出以下建议：

使用道具CODE

尝试运行一个虚拟的宏（宏，基本上什么也不做，但打开工作簿应自动关闭一些活动之后），而不是Answer_Quote()看如果问题依然存在。如果没有，那么您肯定知道Answer_Quote()正在导致该问题。继续进行代码清理。

代码清理

1）集中的所有对象，外部文件和表引用到退出时什么都没有。

可选的，因此同样重要的，但对缓解代码维护和调试，我还建议：

2）使用正确和一致的缩进

3）删除代码冗余线路

例如：

If wBook Is Nothing Then 'Not open 
     Set wBook = Nothing 

如果它已经什么都没有了，那么设置一个无关的引用显然毫无意义。

4）在顶部标出所有变量，而不是整个代码。

5）使用Option explicit（如果你再这样做没有的话）

测试自动闭执行

代码清理后，测试。如果问题仍然存在，请尝试注释掉一些Answer_Quote()代码，然后重试。重复此过程，直到自动关闭执行再次运行，并且可以确定问题的确切原因。

Answer 2

尝试添加停止语句将workbook_open测试，如果事件甚至被触发

Private Sub Workbook_Open() 
    start_Countdown 
    Stop 
End Sub 

这将是一个强力的方式运行从工作簿中调用open事件。

Application.Run(ActiveWorkbook.name & "!Workbook_Open")

添加此您打开工作簿之后。