Действия не запускаются таймером простоя - PullRequest
Новая
       18

Действия не запускаются таймером простоя

0 голосов
/ 04 января 2019

Цель кода - проверить, не занят ли компьютер. Если прошло достаточно времени, то сначала выдается предупреждение о том, что файл собирается сохранить, а затем, если нет ответа в течение еще одного бита времени для автоматического сохранения файла. Тем не менее, таймер простоя не работает при запуске любой из моих подводных лодок. Он работал раньше, когда у меня только что было автосохранение.

Это мой код в 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

Это мои 3 основных подпрограммы в модуле 1, которые произошли из фрагмента кода, который работал нормально, но теперь таймер не работает. Кроме того, теперь, когда 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

Вот подсистема ShowForm, вызываемая WarningMessage: 

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

1 Ответ

0 голосов
/ 04 января 2019

Я думаю, что проблема связана с тем, что в этом разделе 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
...