不活動後自動關閉工作簿

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")

添加此您打開工作簿之後。