Chiudi automaticamente la cartella di lavoro dopo l'inattività

Question

Ho creato una macro che chiude il WB dopo un certo periodo di inattività. Funziona perfettamente se apro il file manualmente, ma se uso un'altra macro da un altro WB per aprire il file, non si chiuderà automaticamente dopo il tempo di inattività impostato. Il codice che ho usato per chiudere automaticamente è:

Questo modulo Workbook:

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 

Modulo Regular:

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 

il codice dell'altro macro:

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 

Qualunque idee?

Answer 1

Come ha sottolineato Susilo nei commenti, il problema deve essere qualcosa di diverso dal codice di chiusura automatica, poiché funziona. Quel "qualcos'altro" quindi, è probabilmente il codice Answer_Quote(), che francamente è un grosso casino. Mi consiglia il seguente:

dummy CODICE

Provate a lanciare una macro fittizia (una macro che essenzialmente fa altro che aprire la cartella di lavoro che dovrebbe auto-chiude dopo un po 'di inattività), invece di Answer_Quote() vedere se il problema persiste. In caso contrario, si è sicuri che il problema sia stato causato da Answer_Quote(). Procedere quindi alla pulizia del codice.

codice di pulitura

1) Impostare tutti gli oggetti, file esterno e riferimenti per cassa verso nulla all'uscita.

Opzionalmente e quindi meno importante, ma per facilitare la manutenzione del codice e il debug, mi piacerebbe anche raccomandare:

2) L'uso corretto e coerente indentazione

3) Rimuovere le linee ridondanti di codice

Ad esempio:

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

Ovviamente è inutile impostare un riferimento a nulla se non è già nulla.

4) Dimensionare tutte le variabili nella parte superiore anziché in tutto il codice.

5) Utilizzare Option explicit (se non già fatto)

AUTO TEST-CHIUDE ESECUZIONE

Dopo pulizia del codice, prova di nuovo. Se il problema persiste, prova a commentare alcuni dei codici Answer_Quote() e riprova. Ripeti questa procedura fino a quando l'esecuzione di chiusura automatica non funziona di nuovo e puoi individuare la causa esatta del problema.

Answer 2

prova ad aggiungere una dichiarazione di arresto per il vostro Workbook_Open per verificare se l'evento è ancora in corso attivato

Private Sub Workbook_Open() 
    start_Countdown 
    Stop 
End Sub 

questo sarebbe un modo forza bruta il eseguire l'evento aperto dal Calling cartella di lavoro.

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

aggiungere questo solo dopo aver aperto la cartella di lavoro.