Mask text in Excel Input box

Question

I made the following macro in Excel. It give access to certain parts of a drop down list if you know the password. Only problem is the text is visible when you type in the password.

How do I make it so that the password in not characters just * or dots?

    Option Explicit
Const human1 As String = "human1"
Const human2 As String = "human2"
Const human3 As String = "human3"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim pwd As String
Dim Oops As Boolean

Application.EnableEvents = False

For Each cell In Target
If Not Intersect(cell, Range("L:L")) Is Nothing And cell <> "" Then
    pwd = Application.InputBox("Password for " & cell & ":", _
                "Enter Password", Type:=2)
    Select Case cell.Value
        Case "human1"
            If pwd <> human1 Then Oops = True
        Case "human2"
            If pwd <> human2 Then Oops = True
        Case "human3"
            If pwd <> human3 Then Oops = True

    End Select
    
    If Oops Then
        MsgBox "Bad password"
        cell = ""
    End If
End If
Next cell

Application.EnableEvents = True
End Sub

score 0 · Answer 1 · answered Aug 25 '20 at 10:05

You are looking for below function. Please read my answer to this post. Masking Password in VBA Excel Input Box

Option Explicit
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, _
    ByVal ncode As LongPtr, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr

Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
    (ByVal idHook As LongPtr, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPtr

Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr

Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As LongPtr, ByVal nIDDlgItem As LongPtr, ByVal wMsg As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr

Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, _
ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As LongPtr

Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As LongPtr

Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

Private hHook As LongPtr


Public Function NewProc(ByVal lngCode As LongPtr, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim RetVal
    Dim strClassName As String, lngBuffer As LongPtr

    If lngCode < HC_ACTION Then
        NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
        Exit Function
    End If

    strClassName = String$(256, " ")
    lngBuffer = 255

    If lngCode = HCBT_ACTIVATE Then
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
    End If

    CallNextHookEx hHook, lngCode, wParam, lParam
End Function

Public Function PasswordBox(Prompt, Title) As String
    Dim lngModHwnd As LongPtr, lngThreadID As LongPtr

    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)

    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

    PasswordBox = InputBox(Prompt, Title)
    UnhookWindowsHookEx hHook
End Function

After declaring this function to a module call the function like below.

Sub MaskedPassword()
    Debug.print PasswordBox("Enter your password.", "Paasword")
End Sub

Finally adopt function to your codes...

Option Explicit
Const human1 As String = "human1"
Const human2 As String = "human2"
Const human3 As String = "human3"

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
Dim pwd As String
Dim Oops As Boolean

Application.EnableEvents = False

For Each cell In Target
If Not Intersect(cell, Range("L:L")) Is Nothing And cell <> "" Then

    pwd = PasswordBox("Enter password for " & cell & ":", "Paasword")

    Select Case cell.Value
        Case "human1"
            If pwd <> human1 Then Oops = True
        Case "human2"
            If pwd <> human2 Then Oops = True
        Case "human3"
            If pwd <> human3 Then Oops = True

    End Select
    
    If Oops Then
        MsgBox "Bad password"
        cell = ""
    End If
End If
Next cell

Application.EnableEvents = True
End Sub

Thanks for the answer. I did declare the function in a module but I can't get it to work. I think I adopt the function into my code wrong. I fumbled around for a bit now but no success. In my code where should I adopt your code the one below? Sub MaskedPassword() Debug.print PasswordBox("Enter your password.", "Paasword") End Sub — Northie, Aug 25 '20 at 11:19
I have already shown to your code. See last part of the answer. — Harun24hr, Aug 25 '20 at 11:44
It is not necessary to user debug.print statement. I have shown an nexample by it. — Harun24hr, Aug 25 '20 at 11:45
This is the line to use the function to your code `pwd = PasswordBox("Enter password for " & cell & ":", "Paasword")` — Harun24hr, Aug 26 '20 at 02:03
@Northie If you found the answer useful then consider accepting the answer. Tick mark the answer. — Harun24hr, Aug 26 '20 at 04:50

Mask text in Excel Input box

1 Answers1