VB - InputBoxEx (Extended InputBox)

[Aaron Young]

The following code creates a wrapper for the standard VB InputBox which subclasses the dialog to allow a number of customizations to be made.

Extended (optional) Functionality includes:
[list=1][*]Changing Background/Foreground Colors[*]Centering the InputBox Dialog[*]Changing Font Name/Size[*]Implement a Customizable Password Character[*]Generating a Cancel Error like the CommonDialog[/list=1]

Simply drop the code into a standard module and away you go.

'*******************************************************
'* InputBoxEx() - Written by Aaron Young, Jan/Feb 2000
'*
'* Usage:
'*
'* Result = InputboxEx( _
'* Message,[Title],[Default],[Default],[XPos],[YPos], _
'* [HelpFile],[Context],[ForeColor],[BackColor], _
'* [FontName],[FontSize],[PasswordChar],[CancelError])
'*
'* This code is Freeware, but if you use it in whole
'* or part, I would appreciate some credit for my work.
'*
'*******************************************************
 
Option Explicit
 
Private Type LOGBRUSH
        lbStyle As Long
        lbColor As Long
        lbHatch As Long
End Type
 
Private Type CWPSTRUCT
        lParam As Long
        wParam As Long
        message As Long
        hwnd As Long
End Type
 
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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 Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 
' System Color Constants
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18
 
' SetWindowPos Constants
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
 
Private Const WH_CALLWNDPROC = 4
 
Private Const GWL_WNDPROC = (-4)
 
' Windows Messages
Private Const WM_GETFONT = &H31
Private Const WM_CREATE = &H1
Private Const WM_CTLCOLORBTN = &H135
Private Const WM_CTLCOLORDLG = &H136
Private Const WM_CTLCOLORSTATIC = &H138
Private Const WM_CTLCOLOREDIT = &H133
Private Const WM_DESTROY = &H2
Private Const WM_SHOWWINDOW = &H18
Private Const WM_COMMAND = &H111
 
Private Const BN_CLICKED = 0
Private Const IDOK = 1
 
Private Const EM_SETPASSWORDCHAR = &HCC
 
' InputboxEx Variables
Private INPUTBOX_HOOK As Long
Private INPUTBOX_HWND As Long
Private INPUTBOX_PASSCHAR As String
Private INPUTBOX_BACKCOLOR As Long
Private INPUTBOX_FORECOLOR As Long
Private INPUTBOX_FONT As String
Private INPUTBOX_FONTSIZE As Integer
Private INPUTBOX_SHOWING As Boolean
Private INPUTBOX_CENTERV As Boolean
Private INPUTBOX_CENTERH As Boolean
Private INPUTBOX_OK As Boolean
 
Private Function InputBoxProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim tLB As LOGBRUSH
    Dim lFont As Long
    Dim tRECT As RECT
    Dim lNotify As Long
    Dim lID As Long
    
    Select Case Msg
    Case WM_COMMAND
        'Check to see if the OK Button was Pressed..
        lNotify = Val("&H" & Left$(Right$("00000000" & Hex$(wParam), 8), 4))
        lID = Val("&H" & Right$(Right$("00000000" & Hex$(wParam), 8), 4))
        If lNotify = BN_CLICKED Then
            INPUTBOX_OK = (lID = IDOK)
        End If
        
    Case WM_SHOWWINDOW
        'Reposition Inputbox if Neccessary
        Call GetWindowRect(hwnd, tRECT)
        If INPUTBOX_CENTERH Then tRECT.Left = ((Screen.Width / Screen.TwipsPerPixelX) - (tRECT.Right - tRECT.Left)) / 2
        If INPUTBOX_CENTERV Then tRECT.Top = ((Screen.Height / Screen.TwipsPerPixelY) - (tRECT.Bottom - tRECT.Top)) / 2
        Call SetWindowPos(hwnd, 0, tRECT.Left, tRECT.Top, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED)
        
    Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC, WM_CTLCOLORBTN, WM_CTLCOLOREDIT
        'Set the Colors
        If Msg = WM_CTLCOLOREDIT Then
            If Len(INPUTBOX_PASSCHAR) Then
                Call SendMessage(lParam, EM_SETPASSWORDCHAR, Asc(INPUTBOX_PASSCHAR), ByVal 0&)
            End If
        Else
            Call SetTextColor(wParam, INPUTBOX_FORECOLOR)
            Call SetBkColor(wParam, INPUTBOX_BACKCOLOR)
            If Msg = WM_CTLCOLORSTATIC Then
                'Set the Font
                lFont = CreateFont(-((INPUTBOX_FONTSIZE / 72) * 96), 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, INPUTBOX_FONT)
                Call SelectObject(wParam, lFont)
            End If
            'Create a Solid Brush using that Color
            tLB.lbColor = INPUTBOX_BACKCOLOR
            'Return the Handle to the Brush to Paint the Inputbox
            InputBoxProc = CreateBrushIndirect(tLB)
            Exit Function
        End If
        
    Case WM_DESTROY
        'Remove the Inputbox Subclassing
        Call SetWindowLong(hwnd, GWL_WNDPROC, INPUTBOX_HWND)
        
    End Select
    InputBoxProc = CallWindowProc(INPUTBOX_HWND, hwnd, Msg, wParam, ByVal lParam)
End Function
 
Private Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim tCWP As CWPSTRUCT
    Dim sClass As String
    'This is where you need to Hook the Inputbox
    CopyMemory tCWP, ByVal lParam, Len(tCWP)
    If tCWP.message = WM_CREATE Then
        sClass = Space(255)
        sClass = Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
        If sClass = "#32770" Then
            If INPUTBOX_SHOWING Then
                'Subclass the Inputbox as it's created
                INPUTBOX_HWND = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf InputBoxProc)
            End If
        End If
    End If
    HookWindow = CallNextHookEx(INPUTBOX_HOOK, nCode, wParam, ByVal lParam)
End Function
 
Public Function InputBoxEx(ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal Default As String, Optional ByVal XPos As Single = -1, Optional ByVal YPos As Single = -1, Optional ByVal HelpFile As String, Optional ByVal Context As Long, Optional ByVal ForeColor As ColorConstants, Optional ByVal BackColor As ColorConstants, Optional ByVal FontName As String, Optional ByVal FontSize As Long, Optional ByVal PasswordChar As String, Optional ByVal CancelError As Boolean = False) As String
    'Set the Defaults
    If Len(Title) = 0 Then Title = App.Title
    INPUTBOX_FONT = "MS Sans Serif"
    INPUTBOX_FONTSIZE = 8
    INPUTBOX_FORECOLOR = GetSysColor(COLOR_BTNTEXT)
    INPUTBOX_BACKCOLOR = GetSysColor(COLOR_BTNFACE)
    INPUTBOX_CENTERH = (XPos = -1)
    INPUTBOX_CENTERV = (YPos = -1)
    INPUTBOX_PASSCHAR = PasswordChar
    'Set the Font and Colors
    If Len(FontName) Then INPUTBOX_FONT = FontName
    If FontSize > 0 Then INPUTBOX_FONTSIZE = FontSize
    If ForeColor > 0 Then INPUTBOX_FORECOLOR = ForeColor
    If BackColor > 0 Then INPUTBOX_BACKCOLOR = BackColor
    'Show the Modified Inputbox
    INPUTBOX_SHOWING = True
    'Monitor All Messages to this Thread.
    INPUTBOX_HOOK = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, App.hInstance, App.ThreadID)
    InputBoxEx = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
    INPUTBOX_SHOWING = False
    'Remove the Hook
    Call UnhookWindowsHookEx(INPUTBOX_HOOK)
    If Not INPUTBOX_OK And CancelError Then Err.Raise vbObjectError + 1, , "User Pressed " & Chr(34) & "Cancel" & Chr(34)
End Function

Example Usage:

Option Explicit
 
Private Sub Command1_Click()
  Dim sReturnVal As String
 
  sReturnVal = _
    InputBoxEx("Enter Password", "InputBoxEx", "password", , , , , vbRed, vbYellow, "Courier New", 10, "*")
End Sub

[RobV10]

I'd like to incorporate your code into an inputbox script that I have. I am particularly intersted in making the input field in the input box configurable. However, I am not sure on what to delete or add to incorporate with the coding that I have. I have made an E-Signature inputbox, but I need for the user inputted text to be astericked or of a different font. Can you look at what I am using and advise on where to add or del. your code?

Thanks in advance.

Private Sub Ctl10_1_1_Enter()
Dim strInputPin As String
If Ctl10_1_1 <> "" Then
    strInputPin = InputBox("Unlock with original signer's pin:")
    Dim rsCheck As ADODB.Recordset
    Set rsCheck = New ADODB.Recordset
    rsCheck.ActiveConnection = CurrentProject.Connection
    rsCheck.CursorType = adOpenKeyset
    rsCheck.LockType = adLockOptimistic
    rsCheck.Open "Select * From tblTrainerSignOffs"
    rsCheck.Find "[strName] = '" & Ctl10_1_1 & "'"
    If rsCheck!strPin = strInputPin Then
        MsgBox ("Sign-off unlocked.")
    Else
        MsgBox ("Pin did not match. Stop cheating.")
        GoTo 998
    End If
    rsCheck.Close
    Set rsCheck = Nothing
Else
End If
 
strInputPin = InputBox("Enter Sign-Off Pin:")
 
Dim rsUsers As ADODB.Recordset
Set rsUsers = New ADODB.Recordset
    rsUsers.ActiveConnection = CurrentProject.Connection
    rsUsers.CursorType = adOpenKeyset
    rsUsers.LockType = adLockOptimistic
    rsUsers.Open "Select * From tblTrainerSignOffs"
    rsUsers.MoveFirst
    Do Until rsUsers.EOF
        If rsUsers!strPin = strInputPin Then
            Ctl10_1_1 = rsUsers!strName
            GoTo 999
        Else
        rsUsers.MoveNext
        End If
    Loop
999 rsUsers.Close
Set rsUsers = Nothing
 
998 [Command34].SetFocus
 
DoCmd.RunCommand (acCmdRefresh)
End Sub

[MartinLiss]

I added [vbcode][/vbcode] tags to your code so that it is easier to read. You can and should add them yourself.

BTW, your use of GoTo to line numbers is error prone and it can also lead to spaghetti code. In your case you could use Exit Do rather than GoTo 999 and DoCmd.RunCommand (acCmdRefresh) followed by Exit Sub instead of GoTo 998.

[tarakwar]

I tried this code just to see output and it shutdown VB project?
Am I missing something here?

[MartinLiss]

Originally posted by tarakwar
I tried this code just to see output and it shutdown VB project?
Am I missing something here?

Aaron 's code uses subclassing and whenever that is done you must exit the code gracefully. In other words you can't use the IDE's End button.

[Aaron Smith]

thanks for everyone replying

i am new to visual basic and i cant work out how to edit the vb form code posted by Aaron Young

I am trying to dim a pass as a string variable.

when i type in:

dim pass as string
pass = sreturnval      'which is the name of the pass stored in mem
if pass = "go" then
msgbox ("HII")
else
msgbox ("LOO")
end if
end sub

it justs comes up saying tht sreturnval is an arguement which cannot be complete or some guff like tht

Hopefully one of you will know the cure to my problems

Regards

Aaron

[MartinLiss]

The code you show obviously isn't your actual code. Why not just cut and paste your real code.

Notice that in Aaron's code he has

Private Sub Command1_Click()
  Dim sReturnVal As String
 
  [HL="#FFFF80"]sReturnVal = _
    InputBoxEx("Enter Password", "InputBoxEx", "password", , , , , vbRed, vbYellow, "Courier New", 10, "*")[/HL]End Sub

That code asks the user for a password. I don't mean to be critical but your code seems to be just trying to grab the password out of thin air since it wouldn't be in memory unless you put it there.

[Aaron Smith]

I am happy that an administrator has replied to my post and martin i aint trying to grab it out of think air

i am going to have to store a password in memory and then i will want as soon as the form runs for the modified inputbox with pass char on it to open up.

Then if the user enters the correct password he will forwarded to a form called

frmghy1

dont ask why if you knew what program i was building it would work out

Hopefully someone out there in the world wide web (VB FORUMS) will be able to help me


Regards

Aaron Smith

[MartinLiss]

I'm not sure I understand, but you can't store anything in memory directly using VB. If you want to store it temorarily in your program you assign it to a variable which has an address in memory which is temporary until you close the program and then it's gone. If you want to store it permanently you need to use the Registry or an ini file or a text file or a database.

[Aaron Smith]

Thanks for replying Martin

As i have said in my previous posts i have no clue about visual basic and dont know wot an ini file is or how to save to the registry

but i will try and expand on my prggy

When the program is run the inputbox will appear but it wont be an ordinary input box it will be an input box with a password character engroseed. So anyway there will be a password stored 'somewhere' and if the user enters a correct password then a form will be displayed and if the user enters an incorrect password then the proggy will terminate,
]

Regards

Aaron

[MartinLiss]

OK, now we're getting someplace Will the password be one that they initially choose or will it be one that you determine?