Standard VBA InputBox Forced Into Taking More Than 256 Characters (Up to 4280) + Other Cool Features.

[Jaafar Tribak]

Hi all,

I have been playing around with the standard vba InputBox to make it more powerful and flexible.

I have named this cutomized vba InputBox as InputBox4280Chars

These are the main added features :
1- Takes up to 4280 Chars.
2- InputBox size automatically adjustable depending on the number of chars\lines written.
3- Added Vertical scrollbar + mousewheel support to the Edit control.
4- ENTER key as a carriage return for quicker multiline text editing.
5- SHIFT + ENTER keys for simulates the user pressing the OK\Cancel buttons.
6- Context right-click menu.
7- Accepts Pasting text into the Edit control.
8- Optional Tooltip (Last Function argument)

Demo file:
_InputBox4280Chars.xls



Here is a preview :







A- Main API code in a Standard Module:

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 TOOLINFO
   cbSize    As Long
   uFlags    As Long
   #If Win64 Then
        hWnd      As LongLong
        uId       As LongPtr
        cRect     As RECT
        hinst     As LongLong
   #Else
        hWnd      As Long
        uId       As Long
        cRect     As RECT
        hinst     As Long
#End If
   lpszText  As String
End Type

#If VBA7 Then
    #If 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
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
    #End 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 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 hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook 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 SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function SendMessageW Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" (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 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 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 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 GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function IsWindow Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long
    Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function ShowWindowAsync Lib "user32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    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 hHook As LongPtr, lPrevInputBoxProc As LongPtr, lPrevEditBoxProc As LongPtr, hInputBox As LongPtr, hToolTip As LongPtr, hNewEdit As LongPtr
#Else
    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 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 hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook 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 SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SendMessage 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 SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function SendMessageW Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Function SetWindowPos Lib "user32.dll" (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 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 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 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
    Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long
    Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function ShowWindowAsync Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) 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 hHook As Long, lPrevInputBoxProc As Long, lPrevEditBoxProc As Long, hInputBox As Long, hToolTip As Long, hNewEdit As Long
#End If

Dim tInputBoxRect As RECT, tOldEditRect As RECT
Dim sRetVal As String, sDefault As String
Dim bToolTip As Boolean


Public Function InputBox4280Chars( _
    Prompt As String, _
    Optional Title As String, _
    Optional Default As String, _
    Optional Xpos As Long, _
    Optional Ypos As Long, _
    Optional Helpfile As String, _
    Optional Context As Long, _
    Optional InfoToolTip As Boolean) As String
   
    Const WH_CBT = 5

    sRetVal = ""
    sDefault = Default
    bToolTip = InfoToolTip
    hHook = SetWindowsHookEx(WH_CBT, AddressOf HookProc, GetModuleHandle(vbNullString), GetCurrentThreadId)
   
    If Xpos Then
        Call InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
    Else
        Call InputBox(Prompt, Title, Default, , , Helpfile, Context)
    End If
   
    InputBox4280Chars = sRetVal

End Function


#If Win64 Then
    Private Function HookProc(ByVal lCode As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
        Dim hOldEdit As LongLong, hFont As LongLong
#Else
    Private Function HookProc(ByVal lCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hOldEdit As Long, hFont As Long
#End If

    Const GWL_WNDPROC = -4
    Const HC_ACTION = 0
    Const HCBT_ACTIVATE = 5
    Const MAX_WIDTH = 4280
    Const WS_CHILD = &H40000000
    Const WS_VISIBLE = &H10000000
    Const WS_BORDER = &H800000
    Const WS_VSCROLL = &H200000
    Const WS_TABSTOP = &H10000
    Const EM_SETLIMITTEXT = &HC5
    Const ES_MULTILINE = &H4&
    Const ES_WANTRETURN = &H1000&
    Const EM_GETLINECOUNT = &HBA
    Const EM_GETRECT = &HB2
    Const WM_GETFONT = &H31
    Const WM_SETFONT = &H30
    Const WM_LBUTTONDOWN = &H201
    Const WM_LBUTTONUP = &H202
    Const MK_LBUTTON = &H1
   
    Dim p1 As POINTAPI, p2 As POINTAPI
    Dim sClassName As String * 256, lRet As Long
    Dim lLinesCount As Long
    Dim lEditStyles As Long
   
    If lCode < HC_ACTION Then
        HookProc = CallNextHookEx(hHook, lCode, wParam, lParam)
        Exit Function
    End If
   
    If lCode = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sClassName, 256)
        If Left$(sClassName, lRet) = "#32770" Then
            Call UnhookWindowsHookEx(hHook)
            hInputBox = wParam
            Call GetWindowRect(hInputBox, tInputBoxRect)
            hOldEdit = GetDlgItem(hInputBox, &H1324)
            Call GetWindowRect(hOldEdit, tOldEditRect)
            hFont = SendMessage(hOldEdit, WM_GETFONT, 0, 0)
            Call DestroyWindow(hOldEdit)
            With tOldEditRect
                p1.x = .Left: p1.y = .Top
                p2.x = .Right: p2.y = .Bottom
                Call ScreenToClient(hInputBox, p1)
                Call ScreenToClient(hInputBox, p2)
                .Left = p1.x: .Top = p1.y
                .Right = p2.x: .Bottom = p2.y
            End With
            lEditStyles = WS_CHILD + WS_VISIBLE + ES_MULTILINE Or WS_VSCROLL + WS_BORDER + ES_WANTRETURN + WS_TABSTOP
            With tOldEditRect
                hNewEdit = CreateWindowEx(0, "Edit", IIf(Len(sDefault) = 0, vbNullString, sDefault), lEditStyles, _
                .Left, .Top, .Right - .Left, .Bottom - .Top, hInputBox, 0, GetModuleHandle(vbNullString), 0)
            End With
            Call SendMessage(hNewEdit, WM_SETFONT, hFont, True)
            Call SendMessage(hNewEdit, EM_SETLIMITTEXT, ByVal MAX_WIDTH, &H0)
            lLinesCount = CLng(SendMessageW(hNewEdit, EM_GETLINECOUNT, 0, 0))
                If Len(sDefault) Then
                Call ResizeInputBox(hInputBox, hNewEdit, lLinesCount)
            End If
            Call PostMessage(hNewEdit, WM_LBUTTONDOWN, MK_LBUTTON, 0)
            Call PostMessage(hNewEdit, WM_LBUTTONUP, MK_LBUTTON, 0)
            Call CreateToolTip
            lPrevInputBoxProc = SetWindowLong(hInputBox, GWL_WNDPROC, AddressOf InputBoxProc)
            lPrevEditBoxProc = SetWindowLong(hNewEdit, GWL_WNDPROC, AddressOf EditBoxProc)
        End If
    End If
   
    Call CallNextHookEx(hHook, lCode, wParam, lParam)
   
End Function


#If Win64 Then
    Private Function InputBoxProc(ByVal hWnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
        Dim hEdit As LongLong
#Else
    Private Function InputBoxProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hEdit As Long
#End If

    Const MAX_WIDTH = 4280
    Const GWL_WNDPROC = -4
    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
    Const WM_COMMAND = &H111
    Const WM_MOVE = &H3
    Const WM_DESTROY = &H2
    Const BN_CLICKED = &H0
    Const BM_CLICK = &HF5&
    Const EN_CHANGE = &H300
    Const EN_UPDATE = &H400
    Const EM_GETLINECOUNT = &HBA
    Const EM_GETLINE = &HC4

    Dim lLinesCount As Long, lLineChars As Long
    Dim sLineBuff As String, i As Long
   
    On Error Resume Next
   
    hEdit = GetDlgItem(hWnd, &H0)
   
    Select Case Msg
   
        Case WM_MOVE
            Call UpdateToolTip(hWnd)
   
            Case WM_SYSCOMMAND
                If wParam = SC_CLOSE Then
                    sRetVal = vbNullString
                End If
   
            Case WM_COMMAND
                    If hiword(CLng(wParam)) = EN_CHANGE Or hiword(CLng(wParam)) = EN_UPDATE Then
                    If loword(CLng(wParam)) = 0 Then    'edit
                        lLinesCount = CLng(SendMessageW(hEdit, EM_GETLINECOUNT, 0, 0))
                            If lLinesCount < 6 Then
                                Call ResizeInputBox(hWnd, hEdit, lLinesCount)
                            End If
                            Call UpdateToolTip(hInputBox)
                    End If
                End If
                If hiword(CLng(wParam)) = BN_CLICKED Then
                    Call RemoveToolTip
                    If loword(CLng(wParam)) = 1 Then     'ok
                        lLinesCount = CLng(SendMessageW(hEdit, EM_GETLINECOUNT, 0, 0))
                        sLineBuff = Space$(MAX_WIDTH)
                        For i = 0 To lLinesCount - 1
                            Mid$(sLineBuff, 1, 1) = ChrW$(MAX_WIDTH)
                            lLineChars = CLng(SendMessageW(hEdit, EM_GETLINE, i, StrPtr(sLineBuff)))
                            sRetVal = sRetVal & Left$(sLineBuff, lLineChars) & vbNewLine
                        Next
                        If Len(sRetVal) Then
                            sRetVal = Left(sRetVal, Len(sRetVal) - 2)
                        End If
                    Else
                        sRetVal = vbNullString
                    End If
                End If
       
            Case WM_DESTROY
                Call RemoveToolTip
                Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevInputBoxProc)
               
    End Select
   
    InputBoxProc = CallWindowProc(lPrevInputBoxProc, hWnd, Msg, wParam, ByVal lParam)

End Function


#If Win64 Then
    Private Function EditBoxProc(ByVal hWnd As LongLong, ByVal Msg As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function EditBoxProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const GWL_WNDPROC = -4
    Const WM_KEYDOWN = &H100
    Const VK_RETURN = &HD
    Const VK_SHIFT = &H10
    Const WM_PASTE = &H302
    Const WM_DESTROY = &H2
    Const BM_CLICK = &HF5&
   
    Dim oDataObj As Object, sClipBoardText As String, lNewLinePos As Long
   
    Select Case Msg
        Case WM_KEYDOWN
            If wParam = VK_RETURN Then
                If GetKeyState(VK_SHIFT) < 0 Then
                    Call SendMessage(GetDlgItem(hInputBox, &H1), BM_CLICK, 0, 0)
                End If
            End If
     
        Case WM_PASTE
            On Error Resume Next
                Set oDataObj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                oDataObj.GetFromClipboard
                sClipBoardText = oDataObj.GetText
                If Len(sClipBoardText) Then
                    lNewLinePos = InStr(sClipBoardText, vbNewLine)
                    Call ResizeInputBox(hInputBox, hWnd, lNewLinePos)
                End If
            On Error GoTo 0
            Set oDataObj = Nothing
        Case WM_DESTROY
            Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevEditBoxProc)
    End Select
   
    EditBoxProc = CallWindowProc(lPrevEditBoxProc, hWnd, Msg, wParam, ByVal lParam)

End Function


#If Win64 Then
    Private Sub ResizeInputBox(ByVal hInput As LongLong, hEdit As LongLong, ByVal LinesCount As Long)
#Else
    Private Sub ResizeInputBox(ByVal hInput As Long, hEdit As Long, ByVal LinesCount As Long)
#End If

    Const SWP_NOMOVE = &H2
    Const SWP_SHOWWINDOW = &H40
    Const SWP_FRAMECHANGED = &H20

    With tOldEditRect
        Call SetWindowPos(hEdit, 0, 0, 0, .Right - .Left, _
        0 + (tOldEditRect.Bottom - tOldEditRect.Top) * IIf(LinesCount > 5, 5, LinesCount), SWP_SHOWWINDOW + SWP_NOMOVE + SWP_FRAMECHANGED)
    End With
    With tInputBoxRect
        Call SetWindowPos(hInput, 0, 0, 0, .Right - .Left, (.Bottom - .Top) _
        + ((tOldEditRect.Bottom - tOldEditRect.Top) * IIf(LinesCount > 5, 5, LinesCount)) - (tOldEditRect.Bottom - tOldEditRect.Top), _
        SWP_SHOWWINDOW + SWP_NOMOVE)
    End With
    Call ShowWindowAsync(hInput, 1)
   
End Sub



#If Win64 Then
    Private Sub UpdateToolTip(ByVal hParent As LongLong)
#Else
    Private Sub UpdateToolTip(ByVal hParent As Long)
#End If

    Const WM_USER = &H400
    Const TTF_TRACK = &H20
    Const TTM_SETDELAYTIME = (WM_USER + 3)
    Const TTM_ADDTOOL = (WM_USER + 4)
    Const TTM_UPDATETIPTEXT = (WM_USER + 12)
    Const TTM_TRACKACTIVATE = (WM_USER + 17)
    Const TTM_TRACKPOSITION = (WM_USER + 18)
    Const TTM_UPDATE = (WM_USER + 29)
    Const TTM_SETTITLEA = (WM_USER + 32)
    Const WM_GETTEXT = &HD&
    Const WM_GETTEXTLENGTH = &HE&
    Const EM_GETLINECOUNT = &HBA
    Const MAX_WIDTH = 4280

    Dim sBallonText As String, sBallonTitle As String, lTextLen As Long
    Dim lCharCount As Long, lLinesCount As Long
    Dim tNewEditRect As RECT, tToolInfo As TOOLINFO

    If bToolTip Then
        If hToolTip Then
            lLinesCount = CLng(SendMessageW(hNewEdit, EM_GETLINECOUNT, 0, 0))
            lTextLen = GetWindowTextLength(hNewEdit)
            Call SysReAllocStringLen(VarPtr(sBallonText), , lTextLen)
            Call SendMessage(hNewEdit, WM_GETTEXT, lTextLen + 1&, StrPtr(sBallonText))
            lCharCount = Len(sBallonText)
            sBallonText = "Total chars: " & lCharCount & Space(10)
            sBallonText = sBallonText & "Total Lines: " & lLinesCount
            If lCharCount >= MAX_WIDTH Then
                sBallonText = "MAX chars reached ! " & Space(10) & lCharCount
            End If
            Call GetWindowRect(hNewEdit, tNewEditRect)
            With tToolInfo
                .cbSize = LenB(tToolInfo)
                .hWnd = hParent
                .uFlags = TTF_TRACK
                .uId = hParent
                .lpszText = sBallonText
            End With
            Call SendMessageAny(hToolTip, TTM_SETTITLEA, 1, ByVal "Info")
            Call SendMessageAny(hToolTip, TTM_ADDTOOL, 0, tToolInfo)
            Call SendMessageAny(hToolTip, TTM_TRACKACTIVATE, True, tToolInfo)
            Call SendMessageAny(hToolTip, TTM_TRACKPOSITION, ByVal 0&, ByVal MakeDWord(CInt(tNewEditRect.Left), CInt(tNewEditRect.Bottom)))
            Call SendMessageAny(hToolTip, TTM_UPDATETIPTEXT, 0, tToolInfo)
            Call SendMessageAny(hToolTip, TTM_UPDATE, 0, 0)
            Call SetProp(Application.hWnd, "ToolTip", hToolTip)
            Call KillTimer(Application.hWnd, 0)
            Call SetTimer(Application.hWnd, 0, 1500, AddressOf HideToolTip)
        End If
    End If

End Sub


Private Sub CreateToolTip()

    Const CW_USEDEFAULT = &H80000000
    Const WS_POPUP = &H80000000
    Const WS_CHILD = &H40000000
    Const TTS_BALLOON = &H40
    Const GWLP_HWNDPARENT = (-8)
   
    If bToolTip Then
        If IsWindow(hToolTip) = 0 Then
            Call 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)
            Call SetWindowLong(hToolTip, GWLP_HWNDPARENT, hInputBox)
            Call UpdateToolTip(hInputBox)
        End If
    End If
   
End Sub


Private Sub HideToolTip()
    Call ShowWindow(GetProp(Application.hWnd, "ToolTip"), 0)
End Sub

Private Sub RemoveToolTip()
    Call KillTimer(Application.hWnd, 0)
    Call DestroyWindow(hToolTip)
    Call RemoveProp(Application.hWnd, "ToolTip")
End Sub

Private Function hiword(DWord As Long) As Long
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function

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 MakeDWord(loword As Integer, hiword As Integer) As Long
    MakeDWord = (hiword * &H10000) Or (loword And &HFFFF&)
End Function

B- InputBox Test :

Option Explicit

Sub Test()

    Dim sRet As String
    
    sRet = InputBox4280Chars("Write Up To (4280) Chars.", "4280 Characters Standard VBA InputBox Demo.", , , , , , True)
   
    If Len(sRet) Then
        MsgBox "You entered : " & vbNewLine & sRet
    ElseIf StrPtr(sRet) = 0 Then
        MsgBox "You Cancelled"
    End If
    
End Sub

Tested on excel 2007, 2013,2016 x32 and x64 bits.

 

[dmt32]

very impressive - a common request made on the forum with standard inputbox is ability to include a password character mask
I know it has been done by Daniel Klann (Mask your Password with this VBA InputBox - wellsr.com ) sometime ago, could this feature be included in your version?

Dave

 

[Jaafar Tribak]

very impressive - a common request made on the forum with standard inputbox is ability to include a password character mask
I know it has been done by Daniel Klann (Mask your Password with this VBA InputBox - wellsr.com ) sometime ago, could this feature be included in your version?

Dave

Yes, that should be easy to add .

I will amend the code in a moment and will post an update

 

[Jaafar Tribak]

very impressive - a common request made on the forum with standard inputbox is ability to include a password character mask
I know it has been done by Daniel Klann (Mask your Password with this VBA InputBox - wellsr.com ) sometime ago, could this feature be included in your version?

Dave

Spoke too soon... Unfortunately, I've just found out that multiline edit controls do not support password style text.

From the MS Doc :
Edit controls: Multiline edit controls do not support the password style or messages.

Should I think of a workaround, I will let you know.

 

[audeser]

If I have to do it for myselft, I would try a userform with a TextBox as New class with Events, where to put the code that controls the behaviours of the TextBox while input. This way, not needed "Trust access to VBA project". I don't know which one of both solutions will need more lines of code, but IMO they will pretty match. TextBox class container could also control the userform (no matter the name of the userform), so it can handle the redimension of the userform when needed. Even, I think the userform could be a blank one created on the run, but I'm not quite sure if I would be able to add a control referred to a class without asking for the "Trust access", so the user form should exists beforehand, even if very basic.

This way could also solve the Password style thing, as TextBox can be fully controlled. It's a workaround, not a pretty solution . Should try for myself...