Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,797
- Office Version
- 2016
- Platform
- Windows
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:
Here is an example of how to use the timed InputBox :
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:
Code:
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 FunctionHere is an example of how to use the timed InputBox :
Code:
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
Last edited:
