Timed InputBox

[Jaafar Tribak]

Hi all,

I have seen this requested on some occasions and the usual answer is to create a userform that looks and behaves like an inputbox and then use OnTime to schedule the closing of the userform upon time-out.

In case anyone is interested, I am showing here an alternative that uses the actual standard vba InputBox function to which I have added an extra optional argument at the end named SecondsTimeOut

Add a new Standard Module to your VBProject and give the module the name of : TimedInputBas

Place this code in the added module:

Option Explicit

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" (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" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetLastActivePopup Lib "user32" (ByVal hwndOwnder As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
 
Private Const IDCANCEL = &H2
Private Const BM_CLICK = &HF5


Function Timed_InputBox( _
    Prompt, _
    Optional Title, _
    Optional Default, _
    Optional XPos, _
    Optional YPos, _
    Optional HelpFile, _
    Optional Context, _
    Optional SecondsTimeOut As Single _
) As String

    Static bFlag As Boolean
    Static hwnd As Long
    Static sTimer As Single
    Static sTimeOut As Single
    
    On Error GoTo ErrHandler
    
    If bFlag = False Then
        bFlag = True
        SetTimer Application.hwnd, 0, 0, AddressOf TimedInputbas.Timed_InputBox
        hwnd = 0
        sTimer = Timer
        If SecondsTimeOut <= 0 Then KillTimer Application.hwnd, 0: bFlag = False Else sTimeOut = SecondsTimeOut
        Timed_InputBox = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
        If bFlag = False And SecondsTimeOut > 0 Then Timed_InputBox = "InputBox Timed-Out"
        Exit Function
    End If
    
    If hwnd = 0 Then hwnd = CLng(GetActiveWindow)
    
    If (Timer - sTimer) >= sTimeOut Or GetLastActivePopup(Application.hwnd) = Application.hwnd Then
        bFlag = False
        KillTimer Application.hwnd, 0
        Call SendMessage(GetDlgItem(hwnd, IDCANCEL), BM_CLICK, 0, ByVal 0)
    End If
    
    Exit Function
    
ErrHandler:
    KillTimer Application.hwnd, 0
    
End Function

Here is an example of how to use the timed InputBox :

Option Explicit

Sub Test()

    Dim sInputText As String
    
    sInputText = Timed_InputBox(Prompt:="Enter Some Text :", Title:="Time-Out InputBox Demo.", SecondsTimeOut:=6) [COLOR=#008000]'Wait 6 Secs for user input.[/COLOR]
    
    MsgBox sInputText

End Sub

 

[Jaafar Tribak]

awesome code @Jaafar Tribak . It is possible to include the character used and left near the countdown. Also, is it possible to increase the character count to 1000?

Sorry, I am not sure what you mean exactly. If you are refering to the InputBox Prompt text, I believe the max number of characters is 1024.

Try experimenting by introducing some new lines & spaces in the prompt string until you obtain the text near the countdown.

This worked for me:

Option Explicit

Sub Test()

    Dim sInputText As String
    Dim sPrompt As String
 
    sPrompt = "Please,enter some text:" & String(4&, vbNewLine)
    sPrompt = sPrompt & Space(62&) & "Countdown " & "->"
 
    'Wait 20 Secs for user input.
    sInputText = Timed_InputBox(Prompt:=sPrompt, Title:="Time-Out InputBox Demo.", SecondsTimeOut:=20, _
    ShowCountDown:=True)
 
    MsgBox sInputText

End Sub