Cool Customized standard InputBox to allow validating input as you type in.

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,393
Office Version
  1. 2016
Platform
  1. 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:
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 Function



2- 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 Sub

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.
 

Tom.Jones

Active Member
Joined
Sep 20, 2011
Messages
358
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Excellent as always, Jaafar. Tested on Excel 2016 32-bit on Win 10.

The only thing is that I think the balloon tip for the maximum number of characters should appear only if you try to exceed the maximum.

You can fix maximum=0 then you have pop-up from the beginning.
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,393
Office Version
  1. 2016
Platform
  1. Windows
Excellent as always, Jaafar. Tested on Excel 2016 32-bit on Win 10.

The only thing is that I think the balloon tip for the maximum number of characters should appear only if you try to exceed the maximum.

Thank you John for testing and thank you for spotting that subtle logic bug regarding the premature appearance of the balloon tip before exceeding the maximum number of chars.

I am working on it and will post back in a few moments.
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,393
Office Version
  1. 2016
Platform
  1. Windows
Ok - I have have now corrected the maximum chars bug pointed out by John_w and I have also added the following functionalities :

A- Added a new parameter to the InputBoxEx function namely (Optional ByVal BalloonTimer As Single)
This timer (in seconds) is supposed to be set by the user to make the balloon tip automatically dismiss itself after the the timer expires.

B- Added an 'X' close button to the balloon tip.

C- Adjusted the balloon tip styles so it accepts multi-line text without loosing the balloon shape.


Workbook Demo Updated Version


1- Main API 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
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () 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
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" () 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, lTickCount 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 Declare Function GetTickCount Lib "kernel32" () As Long

    Private hHook As Long, hToolTip As Long, hInputBox As Long, lTickCount 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 TTS_CLOSE = &H80
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 lBalloonIcon As ICON_TYPE
Private sBalloonTitle As String
Private sBalloonText As String
Private sngBalloonTimer As Single

Private tToolInfo As TOOLINFO
Private bInputBoxInactive As Boolean
Private bMaxCharsReached 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, _
        Optional ByVal BalloonTimer As Single _
    ) As String
    
        sOnKeyEventProcedure = OnKeyEventProcedure
        bPass = PassWordCharacters
        bAllowNumbersOnly = AllowNumbersOnly
        lMaxWidth = MaxChars
        bShowBallon = True
        lBalloonIcon = BalloonIconType
        sBalloonTitle = BalloonTitle
        sBalloonText = BalloonText
        sngBalloonTimer = BalloonTimer
        
        hInputBox = 0
        bInputBoxInactive = False
        
        If hHook = 0 Then
            hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf KeyboardProc, 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]
Private Function KeyboardProc(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
            KeyboardProc = -1
            Exit Function
        End If
        
        If bPass Then
            Call SendMessage(GetFocus, EM_SETPASSWORDCHAR, Asc("*"), &H0)
        End If
        
        If bMaxCharsReached Then
            bMaxCharsReached = False
            If wParam <> vbKeyBack Then
                Call AddToolTip
            End If
        End If
        
        If lMaxWidth Then
            Call SendMessageLong(GetFocus, EM_SETLIMITTEXT, lMaxWidth, 0)
            If GetWindowTextLength(GetFocus) >= lMaxWidth Then
                bMaxCharsReached = True
            Else
                Call RemoveToolTip
            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
                    KeyboardProc = -1
                    Exit Function
                Else
                    Call PostMessage(GetFocus, WM_KEYDOWN, wParam, 0)
                End If
             Else
                 KeyboardProc = -1
                 Exit Function
             End If
         End If
         
    End If
    KeyboardProc = 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 Or TTS_CLOSE, _
        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 IIf(InStr(1, sBalloonText, vbNewLine) Or InStr(1, sBalloonText, vbCr), TTF_ABSOLUTE, 0)
                .uId = GetFocus
                .lpszText = sBalloonText
            End With
            Call SendMessage(hToolTip, TTM_SETTITLEA, lBalloonIcon, ByVal sBalloonTitle)
            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
            lTickCount = GetTickCount
            Call SetTimer(Application.hwnd, 0, 0, AddressOf MonitorInputBoxPos)
        End If
    End If

End Sub


Private Sub MonitorInputBoxPos(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)

    Static tPrevRect As RECT
    Dim tCurRect As RECT, tCaretPos As POINTAPI
    
    If sngBalloonTimer Then
        If (dwTimer - lTickCount) / 1000 >= sngBalloonTimer Then
            Call RemoveToolTip
        End If
    End If

    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 Function



2- Code Usage:
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: " & vbCr & vbCr & 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: " & vbCr & vbCr & sInput
   End If

End Sub


[COLOR=#008000]'Example(3): Set Max number of characters to (4) chars + show balloon tooltip for 5 seconds.[/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." & _
    vbCr & vbCr & "This ToolTip will disappear in:  (5 seconds).", BalloonTimer:=5)
    
    If Len(sInput) Then
        MsgBox "You entered: " & vbCr & vbCr & 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: " & vbCr & vbCr & sInput
    End If

End Sub



[B][COLOR=#008000]'CAUTION!!.[/COLOR][/B]
[B][COLOR=#008000]'=========[/COLOR][/B]
[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 Sub
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,393
Office Version
  1. 2016
Platform
  1. Windows
I am continuing here with this topic and this time, instead of validating the data input via the editbox of the standard vba inputbox as shown in the previous posts(s), I am replacing the native editbox with a combobox control to further facilitate the data input... Again, this is just your standard vba InputBox only that it has been manipulated through the Windows API.

Workbook Demo.


Below is the signature of the new InputBox function called InputBoxCombo

Public Function InputBoxCombo( _
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 ByRef ComboArrayList As Variant, _
Optional ByVal SortComboList As Boolean, _
Optional ByVal AutoFitComboList As Boolean, _
Optional ByVal HorzScrollBar As Boolean, _
Optional ByVal AutoComplete As Boolean, _
Optional ByVal TextColor As Long = vbBlack, _
Optional ByVal BackColor As Long = vbWhite _
) As String



As you can see from the above signature, the InputBoxCombo function allows the user to sort the list, to autofit the dropdown to accomodate the widest entry.. It also allows the user to type letters and the list automatically autocompletes (just like in Google serach engine) and finally it permits changing the text color of the list entries as well as the background.






1- API code in a Standard Module:
Code:
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type DLLVERSIONINFO
    cbSize As Long
    dwMajor As Long
    dwMinor As Long
    dwBuildNumber As Long
    dwPlatformID As Long
End Type

Private Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    ItemId As Long
    itemAction As Long
    itemState As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hwndItem As LongPtr
        hdc As LongPtr
        rcItem As RECT
        itemData As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hwndItem As Long
        hdc As Long
        rcItem As RECT
        itemData As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type COMBOBOXINFO
    cbSize As Long
    rcItem As RECT
    rcButton As RECT
    stateButton  As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hwndCombo  As LongPtr
        hwndEdit  As LongPtr
        hwndList As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hwndCombo  As Long
        hwndEdit  As Long
        hwndList As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type MOUSEHOOKSTRUCT
    pt As POINTAPI
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
        hwnd As LongPtr
        wHitTestCode As Long
        dwExtraInfo As LongPtr
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
End Type

Private Type SCROLLBARINFO
    cbSize As Long
    rcScrollBar As RECT
    dxyLineButton As Long
    xyThumbTop As Long
    xyThumbBottom As Long
    reserved As Long
    rgstate(0 To 5) As Long
End Type

 
[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 SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    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 CallNextHookEx Lib "user32" (ByVal hCBTHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hCBTHook As LongPtr) 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    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 Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function DllGetVersion Lib "comctl32.dll" (pdvi As DLLVERSIONINFO) As Long
    Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SetGraphicsMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal iMode As Long) As Long
    Private Declare PtrSafe Function GetCharWidth32 Lib "gdi32" Alias "GetCharWidth32A" (ByVal hdc As LongPtr, ByVal iFirstChar As Long, ByVal iLastChar As Long, lpBuffer As Long) As Long
    Private Declare PtrSafe Function LPtoDP Lib "gdi32" (ByVal hdc As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As Long
    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 SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBkMode As Long) As Long
    Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare PtrSafe Function GetComboBoxInfo Lib "user32" (ByVal hwndCombo As LongPtr, CBInfo As COMBOBOXINFO) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hdc As LongPtr, ByVal crColor As Long) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, wParam As Any, lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageLong 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 SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) As LongPtr
    Private Declare PtrSafe Function GetScrollBarInfo Lib "user32" (ByVal hwnd As LongPtr, ByVal idObject As Long, psbi As SCROLLBARINFO) As Long
        
    Private hCBTHook As LongPtr, lOldInputBoxProc As LongPtr, hEditBox As LongPtr, hMouseHook As LongPtr, lOldEditProc As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    
    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 CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint 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 CallNextHookEx Lib "user32" (ByVal hCBTHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hCBTHook As Long) 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    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 Sub InitCommonControls Lib "Comctl32.dll" ()
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function DllGetVersion Lib "Comctl32.dll" (pdvi As DLLVERSIONINFO) As Long
    Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, ByVal iMode As Long) As Long
    Private Declare Function GetCharWidth32 Lib "gdi32" Alias "GetCharWidth32A" (ByVal hdc As Long, ByVal iFirstChar As Long, ByVal iLastChar As Long, lpBuffer As Long) As Long
    Private Declare Function LPtoDP Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function GetComboBoxInfo Lib "user32" (ByVal hwndCombo As Long, CBInfo As COMBOBOXINFO) As Long
    Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, wParam As Any, lParam As Any) As Long
    Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Private Declare Function GetScrollBarInfo Lib "user32" (ByVal hwnd As Long, ByVal idObject As Long, psbi As SCROLLBARINFO) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
    
    Private hCBTHook As Long, lOldInputBoxProc As Long, hEditBox As Long, hMouseHook As Long, lOldEditProc As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If


Private Const WH_CBT = 5
Private Const WH_MOUSE = 7
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private Const GWL_WNDPROC = -4&


Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
Private Const WS_HSCROLL = &H100000

Private Const CBS_OWNERDRAWFIXED = &H10&
Private Const CBS_DROPDOWN = &H2&
Private Const CBS_SORT = &H100&
Private Const CBS_HASSTRINGS = &H200&

Private Const WM_COMMAND = &H111
Private Const WM_DESTROY = &H2
Private Const WM_SETFONT = &H30
Private Const WM_SETTEXT = &HC
Private Const WM_KEYDOWN = &H100
Private Const WM_KEYUP = &H101
Private Const WM_DRAWITEM = &H2B
Private Const WM_CTLCOLOREDIT = &H133
Private Const WM_GETTEXTLENGTH = &HE

Private Const CB_GETLBTEXT = &H148
Private Const CB_ADDSTRING = &H143
Private Const CB_SETDROPPEDWIDTH = &H160
Private Const CB_SETMINVISIBLE = &H1701
Private Const CB_SHOWDROPDOWN = &H14F
Private Const CB_DELETESTRING = &H144
Private Const CB_RESETCONTENT = &H14B
Private Const CB_GETCURSEL = &H147
Private Const CB_SETCURSEL = &H14E
Private Const EM_SETSEL = &HB1

Private Const CBN_SELCHANGE = 1
Private Const CBN_EDITCHANGE = 5
Private Const CBN_DROPDOWN = 7
Private Const CBN_SELENDOK = 9

Private Const LB_ITEMFROMPOINT As Long = &H1A9
Private Const LB_SETCURSEL = &H186
Private Const LB_SETHORIZONTALEXTENT = &H194

Private Const SM_CXVSCROLL = 2
Private Const SM_CXHTHUMB = 10
Private Const MM_TEXT = 1
Private Const ANSI_VAR_FONT = 12
Private Const GM_ADVANCED = 2
Private Const SWP_SHOWWINDOW = &H40
Private Const ODT_COMBOBOX = 3
Private Const ODS_SELECTED = &H1
Private Const COLOR_HIGHLIGHT = 13
Private Const COLOR_HIGHLIGHTTEXT = 14
Private Const TRANSPARENT = 1
Private Const OBJID_VSCROLL = &HFFFFFFFB
Private Const OBJID_HSCROLL As Long = &HFFFFFFFA
Private Const MAX_VISIBLE_DROPDOWN_ROWS = 12

Private CBI As COMBOBOXINFO
Private tInitRect As RECT
Private lMaxWidth As Long
Private vArComboArrayList() As Variant
Private bSortComboList As Boolean
Private bAutoFitComboList As Boolean
Private bHorzScrollBar As Boolean
Private bAutoComplete As Boolean
Private lTextColor As Long
Private lBackColor As Long




Public Function InputBoxCombo( _
    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 ByRef ComboArrayList As Variant, _
    Optional ByVal SortComboList As Boolean, _
    Optional ByVal AutoFitComboList As Boolean, _
    Optional ByVal HorzScrollBar As Boolean, _
    Optional ByVal AutoComplete As Boolean, _
    Optional ByVal TextColor As Long = vbBlack, _
    Optional ByVal BackColor As Long = vbWhite _
) As String
    
    vArComboArrayList = ComboArrayList
    bSortComboList = SortComboList
    bAutoFitComboList = AutoFitComboList
    bHorzScrollBar = HorzScrollBar
    bAutoComplete = AutoComplete
    lTextColor = TextColor
    lBackColor = BackColor
    
    If UBound(vArComboArrayList) Then
        hCBTHook = SetWindowsHookEx(WH_CBT, AddressOf CBTProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
    End If
    
    InputBoxCombo = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)

End Function



[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Dim hComboBox As LongPtr, hdc As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hComboBox As Long, hdc As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
         
    Dim tEditRect As RECT
    Dim lpPoint() As POINTAPI, tPt1 As POINTAPI, tPt2 As POINTAPI
    Dim lPrevMapMode As Long, lPrevGrraphicMode As Long
    Dim vElement As Variant, lArrayIndex As Long
    Dim lLogCharWidth As Long, lMaxPixWidth As Long, lPrevMaxPixWidth As Long
    Dim sClassName As String * 256, lRet As Long
    
    On Error GoTo errHandler
     
    If nCode = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sClassName, 256)
        If Left(sClassName, lRet) = "#32770" Then
            UnhookWindowsHookEx hCBTHook
            hEditBox = GetDlgItem(wParam, &H1324)
            Call GetWindowRect(hEditBox, tEditRect)
            Call ShowWindow(hEditBox, 0)
            Call InitCommonControls
            hComboBox = CreateWindowEx(0, "COMBOBOX", "A Combobox", CBS_DROPDOWN Or _
            CBS_OWNERDRAWFIXED + WS_CHILD + CBS_HASSTRINGS + IIf(bSortComboList, CBS_SORT, 0) + WS_VISIBLE + WS_VSCROLL + _
            IIf(bHorzScrollBar, WS_HSCROLL, 0), 0, 0, 0, 0, wParam, 0&, GetModuleHandle(vbNullString), 0&)
            With tEditRect
                tPt1.X = .Left: tPt1.Y = .Top: tPt2.X = .Right: tPt2.Y = .Bottom
            End With
            Call ScreenToClient(hComboBox, tPt1)
            Call ScreenToClient(hComboBox, tPt2)
            Call MoveWindow(hComboBox, tPt1.X, tPt1.Y, tPt2.X - tPt1.X, IIf(Val(CommonControlsVer) >= 6, tPt2.Y - tPt1.Y, tPt2.Y - tPt1.Y + 200), 1)
            CBI.cbSize = Len(CBI)
            Call GetComboBoxInfo(hComboBox, CBI)
            Call SetComboWidth(hComboBox, vArComboArrayList)
            
            If lOldInputBoxProc = 0 Then
                lOldInputBoxProc = SetWindowLong(wParam, GWL_WNDPROC, AddressOf InputBoxProc)
            End If
            
            If lOldEditProc = 0 Then
                lOldEditProc = SetWindowLong(CBI.hwndEdit, GWL_WNDPROC, AddressOf EditWinProc)
            End If
            
            If hMouseHook = 0 Then
                hMouseHook = SetWindowsHookEx(WH_MOUSE, AddressOf MouseProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
            End If
        End If
    End If
    Call CallNextHookEx(hCBTHook, nCode, wParam, lParam)
     
    Exit Function
errHandler:
    UnhookWindowsHookEx hCBTHook
 
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function InputBoxProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Dim hBrush1 As LongPtr, hBrush2 As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function InputBoxProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hBrush1 As Long, hBrush2 As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim tItem As DRAWITEMSTRUCT, tSCBInf As SCROLLBARINFO, tEditRect As RECT
    Dim sSubsetList() As String, vTempAr() As Variant, i As Long
    Dim sBuffer As String * 256, sItemText As String * 256, sEditText As String
    Dim lEditTextLen As Long, LoWord As Long, HiWord As Long, lRet As Long
    
    On Error GoTo errHandler
    lRet = CLng(SendMessageLong(CBI.hwndCombo, CB_SETMINVISIBLE, MAX_VISIBLE_DROPDOWN_ROWS, 0))
     
    Select Case uMsg
    
        Case WM_CTLCOLOREDIT
            Call SetBkMode(wParam, TRANSPARENT)
            Call SetTextColor(wParam, lTextColor)
            Call SetBkColor(wParam, lBackColor)
            InputBoxProc = CreateSolidBrush(lBackColor)
            Exit Function
            
        Case WM_DRAWITEM
            On Error Resume Next
            Call CopyMemory(tItem, ByVal lParam, Len(tItem))
            If tItem.CtlType = ODT_COMBOBOX Then
                Call SendMessageByString(tItem.hwndItem, CB_GETLBTEXT, tItem.ItemId, ByVal sItemText)
                sItemText = Left(sItemText, InStr(sItemText, vbNullChar) - 1)
                If (tItem.itemState And ODS_SELECTED) Then
                    hBrush1 = CreateSolidBrush(GetSysColor(COLOR_HIGHLIGHT))
                    Call SelectObject(tItem.hdc, hBrush1)
                    Call FillRect(tItem.hdc, tItem.rcItem, hBrush1)
                    Call SetTextColor(tItem.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))
                    Call SetBkMode(tItem.hdc, TRANSPARENT)
                    Call TextOut(tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItemText, Len(sItemText))
                    Call DeleteObject(hBrush1)
                Else
                    hBrush2 = CreateSolidBrush(lBackColor)
                    Call SelectObject(tItem.hdc, hBrush2)
                    Call FillRect(tItem.hdc, tItem.rcItem, hBrush2)
                    Call SetTextColor(tItem.hdc, lTextColor)
                    Call SetBkMode(tItem.hdc, TRANSPARENT)
                    Call TextOut(tItem.hdc, tItem.rcItem.Left, tItem.rcItem.Top, ByVal sItemText, Len(sItemText))
                    Call DeleteObject(hBrush2)
                End If
             End If
            On Error GoTo 0
            
        Case WM_COMMAND
            Call GetHiLoword(CLng(wParam), LoWord, HiWord)
            Call SendMessageLong(CBI.hwndList, LB_SETHORIZONTALEXTENT, lMaxWidth, 0)
            
            If wParam = 1 Then
                Call SendMessageByString(hEditBox, WM_SETTEXT, 0, Left(sBuffer, GetWindowText(CBI.hwndEdit, sBuffer, 256)))
            End If
            
            If HiWord = CBN_DROPDOWN Then
                If SendMessage(CBI.hwndEdit, WM_GETTEXTLENGTH, 0&, ByVal 0&) = 0 Then
                    Call SendMessageLong(CBI.hwndCombo, CB_RESETCONTENT, 0, 0)
                    Call GetWindowRect(CBI.hwndEdit, tEditRect)
                    With tEditRect
                        Call SetWindowPos(CBI.hwndList, 0, .Left, .Top + (.Bottom - .Top) + 4, _
                        IIf(lRet, 0, 4) + Max(SetComboWidth(CBI.hwndCombo, vArComboArrayList), (.Right - .Left)), _
                        Min((CBI.rcItem.Bottom - CBI.rcItem.Top) * UBound(vArComboArrayList), (CBI.rcItem.Bottom - CBI.rcItem.Top) * MAX_VISIBLE_DROPDOWN_ROWS), SWP_SHOWWINDOW)
                    End With
                End If
            End If
            
            If HiWord = CBN_SELENDOK Then
                Call ShowWindow(CBI.hwndList, 0)
                lEditTextLen = CLng(SendMessage(CBI.hwndEdit, WM_GETTEXTLENGTH, 0&, ByVal 0&))
                Call SendMessageLong(CBI.hwndEdit, EM_SETSEL, ByVal lEditTextLen, ByVal lEditTextLen)
            End If
            
            If HiWord = CBN_SELCHANGE Then
                If bAutoComplete Then
                    If IsWindowVisible(CBI.hwndList) = 0 Then
                        If GetAsyncKeyState(VBA.vbKeyDown) Then
                            Call SendMessageLong(CBI.hwndCombo, CB_SHOWDROPDOWN, True, 0)
                        End If
                    End If
                End If
            End If
            
            If HiWord = CBN_EDITCHANGE Then
                If bAutoComplete Then
                    sSubsetList = Split(Trim(Join(Filter(Split("|" & Join(vArComboArrayList, Chr(2) & "|"), Chr(2)), "|" & Left(sBuffer, GetWindowText(CBI.hwndEdit, sBuffer, 256)), compare:=vbTextCompare), "")), "|")
                    If UBound(sSubsetList) <> -1 And SendMessage(CBI.hwndEdit, WM_GETTEXTLENGTH, 0&, ByVal 0&) <> 0 Then
                        For i = 0 To UBound(sSubsetList)
                            ReDim Preserve vTempAr(i)
                            vTempAr(i) = CStr(sSubsetList(i))
                        Next i
                        sEditText = Left(sBuffer, GetWindowText(CBI.hwndEdit, sBuffer, 256))
                        Call SendMessageLong(CBI.hwndCombo, CB_RESETCONTENT, 0, 0)
                        tSCBInf.cbSize = Len(tSCBInf)
                        Call GetScrollBarInfo(CBI.hwndList, OBJID_VSCROLL, tSCBInf)
                        Call GetWindowRect(CBI.hwndEdit, tEditRect)
                        With tEditRect
                            Call SetWindowPos(CBI.hwndList, 0, .Left - 2, .Top + (.Bottom - .Top) + 4, _
                            IIf(lRet, 0, 4) + Max(SetComboWidth(CBI.hwndCombo, vTempAr), (.Right - .Left)) + IIf(tSCBInf.rcScrollBar.Left = 0, GetSystemMetrics(SM_CXHTHUMB) + 4, 0), _
                            Min((CBI.rcItem.Bottom - CBI.rcItem.Top) * UBound(vTempAr), (CBI.rcItem.Bottom - CBI.rcItem.Top) * MAX_VISIBLE_DROPDOWN_ROWS), SWP_SHOWWINDOW)
                        End With
                        Call SendMessageByString(CBI.hwndEdit, WM_SETTEXT, 0, sEditText)
                        lEditTextLen = CLng(SendMessage(CBI.hwndEdit, WM_GETTEXTLENGTH, 0&, ByVal 0&))
                        Call SendMessageLong(CBI.hwndEdit, EM_SETSEL, ByVal lEditTextLen, ByVal lEditTextLen)
                    Else
                        Call ShowWindow(CBI.hwndList, 0)
                    End If
                End If
            End If
            
        Case WM_DESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lOldInputBoxProc)
            lOldInputBoxProc = 0
            Call UnhookWindowsHookEx(hMouseHook): hMouseHook = 0
            
    End Select
    
    InputBoxProc = CallWindowProc(lOldInputBoxProc, hwnd, uMsg, wParam, lParam)
    Exit Function
    
errHandler:
    Call SetWindowLong(hwnd, GWL_WNDPROC, lOldInputBoxProc): lOldInputBoxProc = 0
    
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function EditWinProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function EditWinProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
    
    Dim sBuffer As String * 256, lRet As Long, lTextLen As Long

    Select Case uMsg
        Case WM_KEYDOWN, WM_KEYUP
            If IsWindowVisible(CBI.hwndList) Then
                If wParam = vbKeyUp Or wParam = vbKeyDown Then
                    lRet = CLng(SendMessageLong(CBI.hwndCombo, CB_GETCURSEL, ByVal 0, ByVal 0))
                    If lRet <> -1 Then
                        lRet = CLng(SendMessageByString(CBI.hwndCombo, CB_GETLBTEXT, lRet, ByVal sBuffer))
                        Call SendMessageByString(hwnd, WM_SETTEXT, 0, ByVal Left(sBuffer, lRet))
                    End If
                    lTextLen = CLng(SendMessage(hwnd, WM_GETTEXTLENGTH, 0&, ByVal 0&))
                    Call SendMessageLong(hwnd, EM_SETSEL, ByVal lTextLen, ByVal lTextLen)
                End If
            ElseIf wParam = vbKeyDown Then
                With tInitRect
                    Call SetWindowPos(CBI.hwndList, 0, .Left, .Top + (.Bottom - .Top) + 4, .Right - .Left, .Bottom - .Top, SWP_SHOWWINDOW)
                End With
            End If
        Case WM_DESTROY
            Call SetWindowLong(hwnd, GWL_WNDPROC, lOldEditProc)
            lOldEditProc = 0
    End Select
    
    EditWinProc = CallWindowProc(lOldEditProc, hwnd, uMsg, wParam, lParam)
    Exit Function
    
errHandler:
    Call SetWindowLong(hwnd, GWL_WNDPROC, lOldEditProc): lOldEditProc = 0
    
End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MOUSEHOOKSTRUCT) As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MOUSEHOOKSTRUCT) As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Static lPrevRet As Long
    Dim tSCBInf1 As SCROLLBARINFO
    Dim tSCBInf2 As SCROLLBARINFO
    Dim p1 As Long, p2 As Long, lP As Long, lRet As Long, lIndex As Long
     
    On Error GoTo errHandler
    
    If nCode = HC_ACTION Then
        tSCBInf1.cbSize = Len(tSCBInf1)
        Call GetScrollBarInfo(CBI.hwndList, OBJID_VSCROLL, tSCBInf1)
        tSCBInf2.cbSize = Len(tSCBInf2)
        Call GetScrollBarInfo(CBI.hwndList, OBJID_HSCROLL, tSCBInf2)
        
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  Win64 And VBA7 Then
            Dim lPt As LongPtr, hwnd As LongPtr
            Call CopyMemory(lPt, lParam.pt, LenB(lParam.pt))
            hwnd = WindowFromPoint(lPt)
            p1 = PtInRect(tSCBInf1.rcScrollBar, lPt)
            p2 = PtInRect(tSCBInf2.rcScrollBar, lPt)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
            Dim hwnd As Long
            hwnd = WindowFromPoint(lParam.pt.X, lParam.pt.Y)
            p1 = PtInRect(tSCBInf1.rcScrollBar, lParam.pt.X, lParam.pt.Y)
            p2 = PtInRect(tSCBInf2.rcScrollBar, lParam.pt.X, lParam.pt.Y)
        [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
        
        If hwnd = CBI.hwndList And p1 = 0 And p2 = 0 Then
            Call ScreenToClient(CBI.hwndList, lParam.pt)
            lP = MAKELPARAM(lParam.pt.X, lParam.pt.Y)
            If hwnd = CBI.hwndList And p1 = 0 And p2 = 0 Then
                lRet = CLng(SendMessageLong(CBI.hwndList, LB_ITEMFROMPOINT, 0, ByVal CLng(lP)))
                lIndex = CLng(SendMessageLong(CBI.hwndList, LB_ITEMFROMPOINT, 0, ByVal CLng(lP)))
                If lRet > -1 Then
                    If lIndex < MAX_VISIBLE_DROPDOWN_ROWS - 2 Then
                        If lPrevRet <> lRet Then
                            Call SendMessage(CBI.hwndList, LB_SETCURSEL, ByVal LWord(CLng(lRet)), ByVal 0)
                        End If
                    End If
                End If
            End If
        End If
    End If
    lPrevRet = CLng(SendMessageLong(CBI.hwndList, LB_ITEMFROMPOINT, 0, ByVal CLng(lP)))
    MouseProc = CallNextHookEx(hMouseHook, nCode, wParam, lParam)
    Exit Function
    
errHandler:
    Call UnhookWindowsHookEx(hMouseHook): hMouseHook = 0

End Function


[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
    Private Function SetComboWidth(ByVal hCb As LongPtr, Arr() As Variant) As Long
        Dim hdc As LongPtr, hFont As LongPtr
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
    Private Function SetComboWidth(ByVal hCb As Long, Arr() As Variant) As Long
        Dim hdc As Long, hFont As Long
[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If

    Dim trect As RECT
    Dim sClassName As String * 256, lRet As Long
    Dim lpPoint() As POINTAPI, tPt1 As POINTAPI, tPt2 As POINTAPI
    Dim lPrevMapMode As Long, lPrevGrraphicMode As Long
    Dim vElement As Variant, lArrayIndex As Long
    Dim lLogCharWidth As Long, lMaxPixWidth As Long, lPrevMaxPixWidth As Long
    Dim lTextLen As Long


    hdc = GetDC(hCb)
    lPrevMapMode = SetMapMode(hdc, MM_TEXT)
    lPrevGrraphicMode = SetGraphicsMode(hdc, GM_ADVANCED)
    hFont = GetStockObject(ANSI_VAR_FONT)
    Call SendMessage(hCb, WM_SETFONT, hFont, 1)
    For Each vElement In Arr
        If Len(vElement) Then
            Call SendMessageByString(hCb, CB_ADDSTRING, 0, ByVal vElement)
            lLogCharWidth = 0
            For lArrayIndex = 1 To Len(vElement)
                Call GetCharWidth32(hdc, CLng(Asc(Mid(vElement, lArrayIndex, 1))), CLng(Asc(Mid(vElement, lArrayIndex, 1))), lLogCharWidth)
                ReDim lpPoint(0)
                lpPoint(0).X = lLogCharWidth: lpPoint(0).Y = 1
                LPtoDP hdc, lpPoint(0), 1
                lLogCharWidth = lPrevMaxPixWidth + lpPoint(0).X
                If lLogCharWidth >= lMaxPixWidth Then lMaxPixWidth = lLogCharWidth
                lPrevMaxPixWidth = lLogCharWidth
            Next lArrayIndex
            lMaxWidth = lMaxPixWidth
            If lPrevMaxPixWidth >= lMaxPixWidth Then lMaxPixWidth = lPrevMaxPixWidth
            lPrevMaxPixWidth = 0
        End If
    Next vElement
    Call SendMessageLong(hCb, CB_SETDROPPEDWIDTH, IIf(bAutoFitComboList, lMaxPixWidth + GetSystemMetrics(SM_CXVSCROLL) + 8, 0), ByVal 0)
    SetComboWidth = IIf(bAutoFitComboList, lMaxPixWidth + GetSystemMetrics(SM_CXVSCROLL) + 8, 0)
    Call GetWindowRect(CBI.hwndEdit, tInitRect)
    tInitRect.Right = SetComboWidth + tInitRect.Left
    Call SendMessageLong(hCb, CB_SETMINVISIBLE, MAX_VISIBLE_DROPDOWN_ROWS, 0)
    Call SendMessageLong(hCb, CB_SETCURSEL, 0, 0)
    Call SetFocus(hCb)
    lTextLen = CLng(SendMessage(CBI.hwndEdit, WM_GETTEXTLENGTH, 0&, ByVal 0&))
    Call SendMessageLong(CBI.hwndEdit, EM_SETSEL, ByVal lTextLen, ByVal lTextLen)
    Call SetMapMode(hdc, lPrevMapMode)
    Call SetGraphicsMode(hdc, lPrevGrraphicMode)
    Call ReleaseDC(hCb, hdc)
    Call DeleteObject(hFont)

End Function


Private Function CommonControlsVer() As String
      
    Dim tDVI As DLLVERSIONINFO
    
    tDVI.cbSize = Len(tDVI)
    On Error Resume Next
        DllGetVersion tDVI
    On Error GoTo 0
    CommonControlsVer = tDVI.dwMajor & "." & tDVI.dwMinor
End Function

Private Sub GetHiLoword(lParam As Long, ByRef LoWord As Long, ByRef HiWord As Long)
    LoWord = lParam And &HFFFF&
    HiWord = lParam \ &H10000 And &HFFFF&
End Sub

Private Function LWord(dwValue As Long) As Integer
  CopyMemory LWord, dwValue, 2
End Function

Private Function MAKELONG(wLow As Long, wHigh As Long) As Long
  MAKELONG = LWord(wLow) Or (&H10000 * LWord(wHigh))
End Function

Private Function MAKELPARAM(wLow As Long, wHigh As Long) As Long
  MAKELPARAM = MAKELONG(wLow, wHigh)
End Function

Private Function Min(ByVal X As Long, ByVal Y As Long) As Long
    If X < Y Then Min = X Else Min = Y
End Function

Private Function Max(ByVal X As Long, ByVal Y As Long) As Long
    If X > Y Then Max = X Else Max = Y
End Function




2- Code Usage Examples:
Code:
Option Explicit


[COLOR=#008000]'A list of examples of how to use the functionalities of the InputBoxCombo Function:
'==================================================================================[/COLOR]

Private sInput As String


[COLOR=#008000]'Example(1): Sorted Combo List + colored text.[/COLOR]
Sub Test1()

    Dim List() As Variant
    
    List = Application.Transpose(Range("a2:a222"))
    
    [COLOR=#008000]'call the inputbox[/COLOR]
    sInput = InputBoxCombo( _
    Prompt:="Choose a country from the Sorted Combo below:", Title:="Sorted List Demo.", _
    ComboArrayList:=List, SortComboList:=True, TextColor:=vbRed)
    
    If Len(sInput) Then
        MsgBox "Country Selected:" & vbNewLine & vbNewLine & sInput
    End If

End Sub



[COLOR=#008000]'Example(2): Sorted Combo List + Auto-Complete as you type in editbox.[/COLOR]
Sub Test2()

    Dim List() As Variant
    
    List = Application.Transpose(Range("a2:a222"))
    
    [COLOR=#008000]'call the inputbox[/COLOR]
    sInput = InputBoxCombo( _
    Prompt:="Type in the first letters in the edit box of the combo to filter the countries list:", Title:="Auto-Complete ComboBox Demo.", _
    ComboArrayList:=List, SortComboList:=True, AutoComplete:=True)
    
    If Len(sInput) Then
        MsgBox "Country Selected:" & vbNewLine & vbNewLine & sInput
    End If

End Sub



[COLOR=#008000]'Example(3): Combo List Auto-Adjusts To The Largest Entry.[/COLOR]
Sub Test3()

    Dim List(100) As Variant, i As Long
    
    [COLOR=#008000]'populate the combobox.[/COLOR]
    For i = 0 To 100
        List(i) = i + 1
        If i = 5 Then List(5) = List(5) & " ... ( The CombobBox width automatically adjusts to the Widest Entry ..................  !!! )"
    Next i
    
    [COLOR=#008000]'call the inputbox[/COLOR]
    sInput = InputBoxCombo( _
    Prompt:="Click the Dropdown box or press the down arrow key to exapand the auto-fit list:", Title:="VBA InputBoxCombo Demo.", _
    ComboArrayList:=List, AutoComplete:=True, AutoFitComboList:=True)
    
    If Len(sInput) Then
        MsgBox "Item Selected:" & vbNewLine & vbNewLine & sInput
    End If

End Sub



[COLOR=#008000]'Example(4): Combo List with colored background, colred text and Horiz Scrollbar.[/COLOR]
Sub Test4()

    Dim List(100) As Variant, i As Long
    
   [COLOR=#008000] 'populate the combobox.[/COLOR]
    For i = 0 To 100
        List(i) = i + 1
        'make entry [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=6]#6[/URL]  last enty the widest one.
       If i Mod 5 = 2 Then List(i) = List(i) & " ( Auto-Fit not activated - Use the Horizontal Scroolbar to display the netire text  !!! )"
    Next i
    
    [COLOR=#008000]'call the inputbox[/COLOR]
    sInput = InputBoxCombo( _
    Prompt:="Colored ComboBox with Horizontal Scrollbar:", Title:="VBA InputBoxCombo Demo.", _
    ComboArrayList:=List, HorzScrollBar:=True, TextColor:=vbRed, BackColor:=vbYellow)
    
    If Len(sInput) Then
        MsgBox "Item Selected:" & vbNewLine & vbNewLine & sInput
    End If

End Sub

Tested on Office 2007-2010-2016 32 and 64 bits .
 

KeepTrying

Active Member
Joined
Aug 19, 2012
Messages
273
Office Version
  1. 365
  2. 2010
Platform
  1. Windows

ADVERTISEMENT

Hi Jaafar,

Works like a charm as well on Office 365 32 Bits/Win10 64 Bit. Thanks for sharing it, really awesome.

Have you every thought about to start a blog/make short videos about basics of API-s (of course in connection with Excel VBA)? I know it's a kind of niche market but I'm sure many of us would be interested.

Have a nice weekend.

Kind Regards,

KeepTrying
 

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
18,163
Office Version
  1. 2013
Platform
  1. Windows
Wow this is a lot of code. I always like using UserForms to do projects like this:

I know enough to build a Userform position it where I want and have all the controls I need on the Userform

And program it to do what I want.

I would never know how to modify your code to do maybe exactly what I want.

But glad to see your able to do this and share with others.

I put my Userforms in my Personal Workbook where they are available to be used on any Workbook
 

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
8,393
Office Version
  1. 2016
Platform
  1. Windows
@KeepTrying

Thanks for your feedback .

Have you every thought about to start a blog/make short videos about basics of API-s (of course in connection with Excel VBA)? I know it's a kind of niche market but I'm sure many of us would be interested.

I am just too lazy and too disorganized to commit myself to starting a blog or making videos in a well-organized and thoughtfull manner ... I prefer to randomly post here and, to a lesser extent, on other excel-vba related websites.


@My Aswer Is This

Wow this is a lot of code. I always like using UserForms to do projects like this

Yes, That's why Office included the MSForms library to make developping easy but there are certain programming tasks for which being able to use low-level windows functions is more efficient and sometimes the windows API is the only possible route for achieving certain functionalities.

That said, my real emphasis for working on small API projects like this is on LEARNING and on pushing the bounderies of what can be done with vba alone... I find it fun and gratifying :)
 

KeepTrying

Active Member
Joined
Aug 19, 2012
Messages
273
Office Version
  1. 365
  2. 2010
Platform
  1. Windows
@KeepTrying
I am just too lazy and too disorganized to commit myself to starting a blog or making videos in a well-organized and thoughtfull manner ... I prefer to randomly post here and, to a lesser extent, on other excel-vba related websites.
Thanks for your honesty. On the one hand of course I accept it. On the other hand not :)

As My Aswer Is This wrote:
I would never know how to modify your code to do maybe exactly what I want.
That's my opinion too. I have mixed feelings because your API-s are unbelievable but if I need to customize them, I'm stuck.

Anyway, thanks a lot and please keep them posting. Have a great day.
 
Last edited:

Forum statistics

Threads
1,148,342
Messages
5,746,192
Members
423,997
Latest member
eakenila

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top