Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,596
- Office Version
- 2016
- Platform
- Windows
Hi all,
Workbook Demo.
As the tilte says, this is just a standard vba inputbox that I have customized with the use of the Windows API in order to validate user input dynamically as you type-in as well as masking the input with a password character (*) if required.
Another cool functionality I added to the function is the ability to show a balloon tooltip to inform the user when an event is fired.
The InputBoxEx function has the following signature:
Function InputBoxEx( _
ByVal Prompt As String, _
Optional ByVal Title As String, _
Optional ByVal Default As String, _
Optional ByVal XPos As Variant, _
Optional ByVal YPos As Variant, _
Optional ByVal HelpFile As String, _
Optional ByVal Context As Long, _
Optional ByVal OnKeyEventProcedure As String, _
Optional ByVal PassWordCharacters As Boolean, _
Optional ByVal AllowNumbersOnly As Boolean, _
Optional ByVal MaxChars As Long, _
Optional ByVal ShowBalloon As Boolean, _
Optional ByVal BalloonIconType As ICON_TYPE, _
Optional ByVal BalloonTitle As String, _
Optional ByVal BalloonText As String _
) As String
Among the arguments, there is this interesting OnKeyEventProcedure parameter which takes the name of the event callback routine whose signature is in line with the standard Office events layout (See the Test4 example routine below)
The callback routine is passed two arguments : (1) Byval the ASCII code of the character being typed-in and (2) ByRef a Cancel argument to stop the character from being entered into the InputBox.
1- Code in a Standard Module:
2- Code Usage examples:
I 've only tested the code on Excel 2016 64bit Windows 64bit and Excel 2007 Windows 64bit/32bit and I haven't notice any issues.
Workbook Demo.
As the tilte says, this is just a standard vba inputbox that I have customized with the use of the Windows API in order to validate user input dynamically as you type-in as well as masking the input with a password character (*) if required.
Another cool functionality I added to the function is the ability to show a balloon tooltip to inform the user when an event is fired.
The InputBoxEx function has the following signature:
Function InputBoxEx( _
ByVal Prompt As String, _
Optional ByVal Title As String, _
Optional ByVal Default As String, _
Optional ByVal XPos As Variant, _
Optional ByVal YPos As Variant, _
Optional ByVal HelpFile As String, _
Optional ByVal Context As Long, _
Optional ByVal OnKeyEventProcedure As String, _
Optional ByVal PassWordCharacters As Boolean, _
Optional ByVal AllowNumbersOnly As Boolean, _
Optional ByVal MaxChars As Long, _
Optional ByVal ShowBalloon As Boolean, _
Optional ByVal BalloonIconType As ICON_TYPE, _
Optional ByVal BalloonTitle As String, _
Optional ByVal BalloonText As String _
) As String
Among the arguments, there is this interesting OnKeyEventProcedure parameter which takes the name of the event callback routine whose signature is in line with the standard Office events layout (See the Test4 example routine below)
The callback routine is passed two arguments : (1) Byval the ASCII code of the character being typed-in and (2) ByRef a Cancel argument to stop the character from being entered into the InputBox.
1- Code in a Standard Module:
Code:
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type TOOLINFO
cbSize As Long
uFlags As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
hWnd As LongPtr
uId As LongPtr
cRect As RECT
hinst As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
hWnd As Long
uId As Long
cRect As RECT
hinst As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
lpszText As String
End Type
Public Enum ICON_TYPE
TTNoIcon
TTIconInfo
TTIconWarning
TTIconError
End Enum
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] VBA7 Then
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL] Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As LongPtr, ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
Private Declare PtrSafe Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare PtrSafe Function ToAscii Lib "user32" (ByVal uVirtKey As Long, ByVal uScanCode As Long, lpbKeyState As Byte, lpwTransKey As Long, ByVal fuState As Long) As Long
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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hClient As LongPtr, ByVal wFlag As Long) As LongPtr
Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private hHook As LongPtr, hToolTip As LongPtr, hInputBox As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL]
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function GetCaretPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function ToAscii Lib "user32" (ByVal uVirtKey As Long, ByVal uScanCode As Long, lpbKeyState As Byte, lpwTransKey As Long, ByVal fuState As Long) As Long
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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hClient As Long, ByVal wFlag As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private hHook As Long, hToolTip As Long, hInputBox As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL] If
Private Const WH_KEYBOARD = &H2
Private Const HC_ACTION = 0
Private Const KF_REPEAT = &H4000
Private Const KF_UP = &H8000
Private Const CW_USEDEFAULT = &H80000000
Private Const WS_POPUP = &H80000000
Private Const WM_USER = &H400
Private Const TTS_BALLOON = &H40
Private Const TTM_ADDTOOL = (WM_USER + 4)
Private Const TTM_TRACKACTIVATE = (WM_USER + 17)
Private Const TTM_TRACKPOSITION = (WM_USER + 18)
Private Const TTM_SETTITLEA = (WM_USER + 32)
Private Const TTF_TRACK = &H20
Private Const TTF_ABSOLUTE = &H80
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const EM_SETLIMITTEXT = &HC5
Private Const EM_GETLIMITTEXT = (WM_USER + 37)
Private Const ES_NUMBER = &H2000&
Private Const ES_PASSWORD = &H20&
Private Const GWL_STYLE = &HFFF0
Private Const WM_KEYDOWN = &H100
Private Const GW_ENABLEDPOPUP = 6
Private sOnKeyEventProcedure As String
Private bPass As Boolean
Private bAllowNumbersOnly As Boolean
Private lMaxWidth As Long
Private bShowBallon As Boolean
Private lBallonIcon As ICON_TYPE
Private sBallonTitle As String
Private sBallonText As String
Private tToolInfo As TOOLINFO
Private bInputBoxInactive As Boolean
Public Function InputBoxEx( _
ByVal Prompt As String, _
Optional ByVal Title As String, _
Optional ByVal Default As String, _
Optional ByVal XPos As Variant, _
Optional ByVal YPos As Variant, _
Optional ByVal HelpFile As String, _
Optional ByVal Context As Long, _
Optional ByVal OnKeyEventProcedure As String, _
Optional ByVal PassWordCharacters As Boolean, _
Optional ByVal AllowNumbersOnly As Boolean, _
Optional ByVal MaxChars As Long, _
Optional ByVal ShowBalloon As Boolean, _
Optional ByVal BalloonIconType As ICON_TYPE, _
Optional ByVal BalloonTitle As String, _
Optional ByVal BalloonText As String _
) As String
sOnKeyEventProcedure = OnKeyEventProcedure
bPass = PassWordCharacters
bAllowNumbersOnly = AllowNumbersOnly
lMaxWidth = MaxChars
bShowBallon = True
lBallonIcon = BalloonIconType
sBallonTitle = BalloonTitle
sBallonText = BalloonText
hInputBox = 0
bInputBoxInactive = False
If hHook = 0 Then
hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf LowLevelKeyboardProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
End If
InputBoxEx = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
Call RemoveToolTip
Call UnhookWindowsHookEx(hHook): hHook = 0
End Function
[B][COLOR=#008000]'PRIVATE ROUTINES.[/COLOR][/B]
[B][COLOR=#008000]'================[/COLOR][/B]
Private Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim oXlApp As Object, bCancel As Boolean
Dim bKeys(255) As Byte, lAscII As Long
On Error GoTo errHandler
If nCode = HC_ACTION Then
If hInputBox = 0 Then hInputBox = GetParent(GetFocus)
Call RemoveToolTip
If wParam = vbKeyEscape Then
Call RemoveToolTip
LowLevelKeyboardProc = -1
Exit Function
End If
If bPass Then
Call SendMessage(GetFocus, EM_SETPASSWORDCHAR, Asc("*"), &H0)
End If
If lMaxWidth Then
Call SendMessageLong(GetFocus, EM_SETLIMITTEXT, lMaxWidth, 0)
If GetWindowTextLength(GetFocus) >= lMaxWidth Then
Call AddToolTip
End If
End If
If bAllowNumbersOnly Then
Call SetWindowLong(GetFocus, GWL_STYLE, GetWindowLong(GetFocus, GWL_STYLE) Or ES_NUMBER)
End If
If Len(sOnKeyEventProcedure) Then
If (lParam And &H80000000) Or (lParam And &H40000000) Then
Call GetKeyboardState(bKeys(0))
Call ToAscii(wParam, 0&, bKeys(0), lAscII, 0&)
Set oXlApp = Application
oXlApp.Run sOnKeyEventProcedure, lAscII, bCancel
If bCancel Then
If bShowBallon Then
Call AddToolTip
End If
LowLevelKeyboardProc = -1
Exit Function
Else
Call PostMessage(GetFocus, WM_KEYDOWN, wParam, 0)
End If
Else
LowLevelKeyboardProc = -1
Exit Function
End If
End If
End If
LowLevelKeyboardProc = CallNextHookEx(hHook, nCode, wParam, lParam)
Exit Function
errHandler:
Call RemoveToolTip
Call UnhookWindowsHookEx(hHook): hHook = 0
MsgBox "Error Number: " & Err.Number & vbNewLine & Err.Description, vbExclamation, "Oops!"
End Function
Private Sub AddToolTip()
Dim tCaretPos As POINTAPI
Call RemoveToolTip
If IsWindow(hToolTip) = 0 Then
InitCommonControls
hToolTip = CreateWindowEx(0, "tooltips_class32", 0, WS_POPUP Or TTS_BALLOON, _
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0, 0, GetModuleHandle(vbNullString), 0)
If hToolTip Then
With tToolInfo
.cbSize = LenB(tToolInfo)
Call GetWindowRect(GetFocus, .cRect)
.hWnd = GetFocus
.uFlags = TTF_TRACK 'Or TTF_ABSOLUTE
.uId = GetFocus
.lpszText = sBallonText
End With
Call SendMessage(hToolTip, TTM_SETTITLEA, lBallonIcon, ByVal sBallonTitle)
Call SendMessage(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
Call GetCaretPos(tCaretPos)
Call ClientToScreen(GetFocus, tCaretPos)
With tCaretPos
.y = .y + 10
Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(.x), CInt(.y)))
End With
Call SetTimer(Application.hWnd, 0, 0, AddressOf MonitorInputBoxPos)
End If
End If
End Sub
Private Sub MonitorInputBoxPos()
Static tPrevRect As RECT
Dim tCurRect As RECT, tCaretPos As POINTAPI
If bInputBoxInactive = False Then
If GetNextWindow(hInputBox, GW_ENABLEDPOPUP) Then
Call SendMessage(hToolTip, TTM_TRACKACTIVATE, False, tToolInfo)
Else
Call GetWindowRect(hInputBox, tCurRect)
With tPrevRect
If (.Left <> tCurRect.Left Or .Top <> tCurRect.Top) And (.Left <> 0) Then
Call GetCaretPos(tCaretPos)
Call ClientToScreen(GetFocus, tCaretPos)
With tCaretPos
.y = .y + 10
Call SendMessage(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
Call SendMessage(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(.x), CInt(.y)))
End With
End If
End With
End If
End If
Call GetWindowRect(hInputBox, tPrevRect)
End Sub
Private Sub RemoveToolTip()
bInputBoxInactive = False
Call KillTimer(Application.hWnd, 0)
Call DestroyWindow(hToolTip)
End Sub
Private Function loword(DWord As Long) As Integer
If DWord And &H8000& Then
loword = DWord Or &HFFFF0000
Else
loword = DWord And &HFFFF&
End If
End Function
Private Function hiword(ByVal DWord As Long) As Integer
hiword = (DWord And &HFFFF0000) \ &H10000
End Function
Private Function MakeDWord(loword As Integer, hiword As Integer) As Long
MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function2- Code Usage examples:
Code:
Option Explicit
[B][COLOR=#008000]'A list of examples of how to use the InputBoxEx Function:[/COLOR][/B]
[B][COLOR=#008000]'========================================================[/COLOR][/B]
Private sInput As String
[COLOR=#008000]'Example(1): Allow Numeric entries only.[/COLOR]
Sub Test1()
sInput = InputBoxEx(Prompt:="Enter a number.", Title:="Test1", AllowNumbersOnly:=True)
If Len(sInput) Then
MsgBox "You entered: " & sInput
End If
End Sub
[COLOR=#008000]'Example(2): Mask input with "*" password character.[/COLOR]
Sub Test2()
sInput = InputBoxEx(Prompt:="Enter a password.", Title:="Test2", PassWordCharacters:=True)
If Len(sInput) Then
MsgBox "You entered: " & sInput
End If
End Sub
[COLOR=#008000]'Example(3): Set Max number of characters to (4) chars.[/COLOR]
Sub Test3()
sInput = InputBoxEx( _
Prompt:="Enter some text.", _
Title:="Test3", MaxChars:=4, _
ShowBalloon:=True, BalloonIconType:=TTIconError, _
BalloonTitle:="Oops!", BalloonText:="You Reached the max number of characters.")
If Len(sInput) Then
MsgBox "You entered: " & sInput
End If
End Sub
[COLOR=#008000]'Example(4): Allow UpperCase letters only ---- (Calls the 'OnkeyEvent callback SUB below)[/COLOR]
Sub Test4()
sInput = InputBoxEx( _
Prompt:="Enter some text.", _
Title:="Test4", OnKeyEventProcedure:="OnKeyEvent", _
ShowBalloon:=True, BalloonIconType:=TTIconInfo, _
BalloonTitle:="Oops!", BalloonText:="Only UpperCase Letters Allowed.")
If Len(sInput) Then
MsgBox "You entered: " & sInput
End If
End Sub
[COLOR=#008000]'CAUTION!!.
'=========[/COLOR]
[COLOR=#008000]'This is a callback routine so it is imporatnt to set up a propper error handler !![/COLOR]
Private Sub OnKeyEvent(ByVal vKey As Long, ByRef Cancel As Boolean)
On Error GoTo errHandler
[COLOR=#008000]'Do not allow lowercase characters.[/COLOR]
If UCase(Chr(vKey)) <> Chr(vKey) Then
Cancel = True
End If
Exit Sub
errHandler:
MsgBox Err.Description
End SubI 've only tested the code on Excel 2016 64bit Windows 64bit and Excel 2007 Windows 64bit/32bit and I haven't notice any issues.
