空闲计时器未触发操作

Question

代码的目标是查看计算机是否空闲。如果经过了足够长的时间，它会首先发出警告，提示文件即将保存，然后如果在另一段时间内没有响应，则自动保存文件。但是，空闲计时器无法触发我的任何潜艇。之前我刚自动保存的时候是可以用的。

这是我在 ThisWorkbook 中的代码，可以自动运行我的 3 个子程序。

Option Explicit

Sub Workbook_Open()
    IdleTime
    WarningMessage
    CloseDownFile
End Sub

命名有点不对，因为 CloseDownFile 实际上并没有关闭文件，但我从未更改过名称。

这是运行没问题的代码：

Private Type LASTINPUTINFO
    cbSize As Long
    dwTime As Long
End Type

Private Declare Sub GetLastInputInfo Lib "user32" (ByRef plii As LASTINPUTINFO)

Private Declare Function GetTickCount Lib "kernel32" () As Long

Function IdleTime() As Single
    Dim a As LASTINPUTINFO
    a.cbSize = LenB(a)
    GetLastInputInfo a
    IdleTime = (GetTickCount - a.dwTime) / 1000
End Function

Public Sub CloseDownFile()
    On Error Resume Next
    If IdleTime > 30 Then
        Application.StatusBar = "Inactive File Closed: " & ThisWorkbook.Name
        ThisWorkbook.Save
    Else
        CloseDownTime = Now + TimeValue("00:00:30") ' change as needed
        Application.OnTime CloseDownTime, "CloseDownFile"
    End If
End Sub

这些是我在模块 1 中的 3 个主要子程序，它们源自运行正常但现在计时器不工作的代码段。此外，现在 Option Explicit 已打开，表示未定义 CloseDownTime：

Option Explicit

Private Type LASTINPUTINFO
    cbSize As Long
    dwTime As Long
End Type

Private Declare Sub GetLastInputInfo Lib "user32" (ByRef plii As LASTINPUTINFO)

Private Declare Function GetTickCount Lib "kernel32" () As Long

Function IdleTime() As Single
    Dim a As LASTINPUTINFO
    a.cbSize = LenB(a)
    GetLastInputInfo a
    IdleTime = (GetTickCount - a.dwTime) / 1000
End Function

Public Sub CloseDownFile()
    On Error Resume Next

    If IdleTime > 30 Then
        Application.StatusBar = "Inactive File Closed: " & ThisWorkbook.Name
        ThisWorkbook.Save
    Else
        CloseDownTime = Now + TimeValue("00:00:30") ' change as needed
        Application.OnTime CloseDownTime, "CloseDownFile"
    End If
End Sub

Public Sub WarningMessage()
    On Error Resume Next

    If IdleTime > 20 Then
        Application.StatusBar = "Saving File" & ThisWorkbook.Name
        ShowForm     
    End If
End Sub

这是 WarningMessage 调用的 ShowForm 子函数：

Option Explicit

Public Sub ShowForm()
    Dim frm As New UserForm1
    frm.BackColor = rgbBlue

    frm.Show
End Sub

这是 Userform1 中的代码运行:

Private Sub CommandButton1_Click()
    Hide
    m_Cancelled = True
    MsgBox "Just Checking!"

    CloseDownTime = Now + TimeValue("00:00:30")
    Application.OnTime CloseDownTime, "WarningMessage"
End Sub

Private Sub Image1_Click()
End Sub

Private Sub CommandButton2_Click()
    Hide
    m_Cancelled = True
    MsgBox "Then how did you respond?"

    CloseDownTime = Now + TimeValue("00:00:30")
    Application.OnTime CloseDownTime, "WarningMessage"
End Sub

Private Sub TextBox1_Change()
End Sub

Answer 1

我认为问题与本节 If IdleTime > 30 Then 中您没有再次启动 Application.OnTime 以继续检查流程有关。此外，由于计时器设置为 30 秒，因此到达此潜艇时总是会超过 30 秒。所以它不会一直检查。

看看像这样构建代码是否有帮助。

Option Explicit

Private Type LASTINPUTINFO
  cbSize As Long
  dwTime As Long
End Type

Public Declare Sub GetLastInputInfo Lib "user32" (ByRef plii As LASTINPUTINFO)
Public Declare Function GetTickCount Lib "kernel32" () As Long

Public Function IdleTime() As Long
    Dim LastInput As LASTINPUTINFO
    LastInput.cbSize = LenB(LastInput)
    GetLastInputInfo LastInput
    IdleTime = (GetTickCount - LastInput.dwTime) \ 1000
End Function

Public Sub CloseDownFile()
    Dim CloseDownTime As Date

    Debug.Print "Going here IdleTime is " & IdleTime

    If IdleTime > 30 Then
        Debug.Print "Saving"
        Application.StatusBar = "Inactive File Closed: " & ThisWorkbook.Name
        ThisWorkbook.Save
    End If

    'You always want to run this code to keep checking
    CloseDownTime = Now + TimeValue("00:00:15")
    Application.OnTime CloseDownTime, "CloseDownFile"
End Sub

Public Sub WarningMessage()
    If IdleTime > 20 Then
        Application.StatusBar = "Saving File" & ThisWorkbook.Name
        ShowForm
    End If
End Sub

Public Sub ShowForm()
    Dim frm As UserForm1: Set frm = New UserForm1
    frm.BackColor = rgbBlue
    frm.Show
 End Sub

空闲计时器未触发操作

Actions are not being triggered by idle timer

excel

vba

undefined

idle-timer