Подтвердить что ты не робот

Автоматически закрывать книгу после бездействия

Я создал макрос, который закрывает 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

Любые идеи?

4b9b3361

ОТВЕТЫ

Ответ 1

Как отметил Сусило в комментариях, проблема должна быть чем-то иным, чем сам код автозакрытия, поскольку он работает. Тогда "что-то другое", вероятно, является кодом Answer_Quote(), который, откровенно говоря, является одним большим беспорядком. Я бы рекомендовал следующее:

ИСПОЛЬЗОВАТЬ DUMMY CODE

Попробуйте запустить фиктивный макрос (макрос, который по существу ничего не делает, кроме как открыть книгу, которая должна автоматически закрыться после некоторой неактивности) вместо Answer_Quote(), чтобы узнать, не исчезла ли проблема. Если это не так, то вы точно знаете, что проблема Answer_Quote() вызывает проблему. Затем выполните очистку кода.

CODE CLEANUP

1) После завершения всех объектов, внешних ссылок на файл и лист ничего не происходит.

Необязательно и, следовательно, менее важно, но для облегчения обслуживания и отладки кода я также рекомендую:

2) Используйте правильный и последовательный отступ

3) Удалите лишние строки кода

Например:

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

Очевидно, бессмысленно указывать ссылку на ничего, если она уже ничего.

4) Измерьте все переменные сверху, а не весь код.

5) Используйте Option explicit (если вы этого еще не сделали)

ВЫПОЛНЕНИЕ АВТОМАТИЧЕСКОГО ЗАКРЫТИЯ

После очистки кода снова проверьте. Если проблема не устранена, попробуйте прокомментировать некоторый код Answer_Quote() и повторите попытку. Повторите этот процесс до тех пор, пока не будет выполнено автоматическое закрытие, и вы сможете точно определить причину проблемы.

Ответ 2

попробуйте добавить инструкцию stop к вашей книге workbook_open, чтобы проверить, запущено ли событие даже

Private Sub Workbook_Open()
  start_Countdown
  Stop
End Sub

это было бы грубой силой, чтобы запустить открытое событие из рабочей книги.

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

добавьте это сразу после открытия рабочей книги.