VBA code to close an inputBox when system is inactive for some time.

[kelly mort]

In a post solved for me here by @Jaafar Tribak I used the computer’s system inactivity to display an inputBox where a user must enter certain credentials to get access to the userform again.

It’s working very great. But there has been new developments and I need help to take care of that.

As pointed out by @Jaafar Tribak the code works for modeless forms - which I have no problem with.

But I do have problems with inputBoxes. That is when an inputBox is active, that prevents @Jaafar Tribak code from running no matter how long the waiting period is.

Then it occurred to me that if I could find a way to close objects or processes such as those for message boxes, inputBoxes and the others, then I would be able to get the Sub running smoothly for me.

And the tricky part is that even if I find an easy way to close message boxes and inputBoxes, that would still present a bigger problem because I would also end up closing the input box I am using to restrict access to the userform.

So I am thinking of a way to id that inputBox so that when it comes to closing them, I will exclude that one.

But I have not been able to come up with anything yet.

For the message boxes, I have scripts from multiple sources that do that.

Could someone please help me out here?

Thanks in advance.

 

[shinigamilight]

Just enable sleep on your pc, that's what people do where I am at. After 10 minutes of inactivity it goes to sleep and asks to re-enter the password.

 

[Jaafar Tribak]

See if this works for you:

This should display the *main* inputbox ie: The one that you want to keep when the idle-time is reached. This Inputbox will stay on display until the user enters in it the required input or dismiss it.

If there happens to be some other inputbox (or any other dialog modal or non-modal) on display when the idle time is up, it will be automatically closed and the *main* InputBox will be displayed.

Distinguishing between the *main* Inputbox and the other Inputboxes is achieved by tagging the title of the *main* Inputbox with a non-breaking space character at the end... Note that you will need to tag the InputBox title with the EndCharacter argument in the UForm_OnIdleTimeReached Pseudo-Event as follows:

InputBox sPrompt, "Test" & EndCharacter

I hope I understood you correctly.

Here is a workbook demo:
IdleTimeout.xlsm



1- In a Standard Module:

Option Explicit

Public Enum TIME_UNIT
    °Seconds = 1&
    °Minutes = 60&
End Enum

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type LASTINPUTINFO
    cbSize As Long
    dwTime As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetTimer Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare PtrSafe Function GetLastInputInfo Lib "user32" (plii As Any) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function SetThreadExecutionState Lib "Kernel32.dll" (ByVal esFlags As Long) As Long
    Private Declare Function GetLastInputInfo Lib "user32" (plii As Any) As Long
#End If
   
Private oForm As Object
Private hForm As LongPtr
Private dMaxIdleTime As Double
Private lUnit As TIME_UNIT



Public Sub InitTimer( _
    ByVal Form As Object, _
    ByVal MaxIdleTime As Double, _
    Optional ByVal Unit As TIME_UNIT = °Seconds _
)

    Set oForm = Form
    If MaxIdleTime <= 0& Then MaxIdleTime = 1&
    dMaxIdleTime = MaxIdleTime * Unit
    lUnit = Unit
    Call IUnknown_GetWindow(Form, VarPtr(hForm))
    If hForm Then
        Call SetTimer(hForm, NULL_PTR, 1000&, AddressOf TimerProc)
    End If
   
End Sub


Public Sub EndTimer(Optional ByVal Dummy As Boolean)
 Call KillTimer(hForm, NULL_PTR)
 PreventSleepMode = False
End Sub



Private Sub TimerProc( _
    ByVal hwnd As LongPtr, _
    ByVal Msg As Long, _
    ByVal idEvent As LongPtr, _
    ByVal dwTime As Long _
)

    Const SC_CLOSE = &HF060&, WM_SYSCOMMAND = &H112
   
    Dim tLInfo As LASTINPUTINFO
    Dim dInterval As Double
    Dim sBuffer As String * 256&, lRet As Long
   
    tLInfo.cbSize = LenB(tLInfo)
    Call GetLastInputInfo(tLInfo)
    dInterval = Int(((dwTime - tLInfo.dwTime) / 1000&))

    If lUnit = °Seconds Then
        dInterval = IIf(dInterval = 1, dInterval + 1&, dInterval - 1&)
    End If

    If (dInterval Mod dMaxIdleTime + 1&) = Int(dMaxIdleTime) Then
       'Idle-Time out reached."
        If GetLastActivePopup(Application.hwnd) <> hwnd Then
            lRet = GetWindowText(GetLastActivePopup(Application.hwnd), sBuffer, 256&)
            If Right(Left(sBuffer, lRet), 1&) <> ChrW(160&) Then
                Call SendMessage(GetLastActivePopup(Application.hwnd), WM_SYSCOMMAND, SC_CLOSE, ByVal 0&)
                Call oForm.UForm_OnIdleTimeReached(dMaxIdleTime / lUnit, lUnit, ChrW(160&))
            End If
        Else
            Call oForm.UForm_OnIdleTimeReached(dMaxIdleTime / lUnit, lUnit, ChrW(160&))
        End If
    End If
   
    PreventSleepMode = True

End Sub


Private Property Let PreventSleepMode(ByVal bPrevent As Boolean)
    Const ES_SYSTEM_REQUIRED = &H1
    Const ES_DISPLAY_REQUIRED = &H2
    Const ES_AWAYMODE_REQUIRED = &H40
    Const ES_CONTINUOUS = &H80000000
 
    If bPrevent Then
        Call SetThreadExecutionState(ES_CONTINUOUS Or ES_DISPLAY_REQUIRED Or ES_SYSTEM_REQUIRED Or ES_AWAYMODE_REQUIRED)
    Else
        Call SetThreadExecutionState(ES_CONTINUOUS)
    End If
End Property

2- Code Usage in the UserForm Module:

Option Explicit

Private Sub UserForm_Initialize()
    'Time-out 1 Minute.
    Call InitTimer(Me, 1, °Minutes)
End Sub

Private Sub UserForm_Terminate()
    Call EndTimer
End Sub

Private Sub CommandButton1_Click()
    InputBox "This InputBox will automatically close when the Idle-timeout is reached !!!", "Test"
End Sub


' _________________________________________ PUBLIC PSEUDO-EVENT _____________________________________________


Public Sub UForm_OnIdleTimeReached( _
    Optional ByVal IdleTimeElapsed As Double, _
    Optional ByVal Unit As TIME_UNIT = °Seconds, _
    Optional ByVal EndCharacter As String _
)

    Dim sPrompt As String, sTimeUnit As String
    
    sTimeUnit = IIf(Unit = °Seconds, "Secs", "Mins")
    
    sPrompt = "The [" & IdleTimeElapsed & "] " & sTimeUnit & " Idle-Timeout was reached." & vbNewLine & vbNewLine & _
    "This InputBox will NOT automatically close because its title string was marqued with a non-breaking space character at the end."
    
    InputBox sPrompt, "Test" & EndCharacter

End Sub

 

[kelly mort]

Wow @Jaafar Tribak this is a very great code you have provided. I have tested the idle times and they are working great.

I am very grateful and I really admire your intelligence.