不活动后自动关闭工作簿

时间：2016-01-20 19:07:25

标签： excel vba excel-vba

我创建了一个宏，在一段时间不活动后关闭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

有什么想法吗？

2 个答案:

答案 0 :(得分：1)

正如Susilo在评论中指出的那样，问题必须是自动关闭代码本身以外的问题，因为它可行。那么“别的东西”可能就是Answer_Quote()代码，坦率地讲是一大堆。我推荐以下内容：

使用虚假代码

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

代码清理

1）退出时将所有对象，外部文件和工作表引用设置为空。

可选，因此不那么重要，但为了简化代码维护和调试，我还建议：

2）使用适当且一致的缩进

3）删除冗余的代码行

例如：

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

如果没有任何参考，那么将参考设置为空是显而易见的。

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

5）使用Option explicit（如果你还没有）

测试自动关闭执行

清除代码后，再次测试。如果问题仍然存在，请尝试注释掉部分Answer_Quote()代码，然后重试。重复此过程，直到自动关闭执行再次起作用，您可以查明问题的确切原因。

答案 1 :(得分：1)

尝试在workbook_open中添加一个stop语句来测试事件是否被触发

Private Sub Workbook_Open()
  start_Countdown
  Stop
End Sub

这将是一种蛮力的方式来运行来自呼叫工作簿的开放事件。

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

在打开工作簿之后添加它。

相关问题
最新问题