vba to request a password for dropdown list entries

[cjcass]

Hi,
I'm looking for a macro/vba that will require a user to enter a password before they can enter a selection from a dropdown list. In the example below the range C5:C10 is named 'Fruit'. The dropdowns to select from the range 'Fruit' are located in G5:G8 but ultimately may end up on another wksheet. So when a user selects, say 'Grape', from a cell dropdown they are prompted for a password. The vba looks up the user's password entry against the list in D5:D10 and if it's correct the selection is allowed, if the password is not correct the user receives an 'incorrect password' message and the cell is left blank. Please note that my 'Fruit' and Password ranges will be bigger than the example and may well change so I need some kind of 'lookup' feature in the vba as opposed to entering all the fruit and passwords into the code. If the the code could also allow the these two ranges to be dynamic in size (number of rows down) then even better!
Any help on this would be much appreciated.
Many thanks.

 

[Peter_SSs]

There is a method suggested here but I have not tried it and it looks quite complicated. Textbox on a userform sounds a better option to me.

 

[cjcass]

Hi,
Had a look at the link and it does look complicated - I'd struggle to resolve any issues if I had any problems with it.
Am not massively familiar with userforms, have you any idea how to create one that gives me the same functionality as your initial solution, using the same cells and password lists etc.?
Will fully understand if you haven't got the time as you've already helped me with this project.
Best Rgds,

 

[Peter_SSs]

Am not massively familiar with userforms,

userforms are also not a strength of mine so I usually leave forum questions about them to others who are far stronger than me in that area. Perhaps somebody else will come along and pick up the challenge.

Perhaps you could spend a bit of time investigating here: How to Create an Excel UserForm for Data Entry

 

[cjcass]

Ok thanks for responding again so quickly I'm now investigating userforms. If I can't find a way then I'll stick with your initial solution which I like as it's very slick thanks again.

If anyone else out there knows how this could work with a userform masking the passwords, please come in on this post, thanks.

 

[Jaafar Tribak]

Hi,
Had a look at the link and it does look complicated - I'd struggle to resolve any issues if I had any problems with it.
Am not massively familiar with userforms, have you any idea how to create one that gives me the same functionality as your initial solution, using the same cells and password lists etc.?
Will fully understand if you haven't got the time as you've already helped me with this project.
Best Rgds,

You don't have to worry about the complexity of the code in the link posted by Peter_SSs

1- Just add a new Standard Module to your vbproject and paste this code in it.

#If VBA7 Then
    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 GetModuleHandle Lib "kernel32" Alias _
        "GetModuleHandleA" (ByVal lpModuleName As String) 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 UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
    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 GetClassName Lib "user32" Alias "GetClassNameA" _
        (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
    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 GetModuleHandle Lib "kernel32" Alias _
        "GetModuleHandleA" (ByVal lpModuleName As String) 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 hHook 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 GetClassName Lib "user32" Alias "GetClassNameA" _
        (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If

'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0

#If VBA7 Then
    Private hHook As LongPtr
#Else
    Private hHook As Long
#End If

'----------------------------------
'PRIVATE PASSWORDS FOR INPUTBOX
'----------------------------------

'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'64-bit modifications developed by Alexey Tseluiko
'and Ryan Wells (wellsr.com)
'February 2019
'////////////////////////////////////////////////////////////////////

#If VBA7 Then
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr
#Else
Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Dim RetVal
    Dim strClassName As String, lngBuffer As Long
    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 'A window has been activated
        RetVal = GetClassName(wParam, strClassName, lngBuffer)
        If Left$(strClassName, RetVal) = "#32770" Then
            'This changes the edit control so that it display the password character *.
            'You can change the Asc("*") as you please.
            SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
        End If
    End If
    'This line will ensure that any other hooks that may be in place are
    'called correctly.
    CallNextHookEx hHook, lngCode, wParam, lParam
End Function

Function InputBoxDK(Prompt, Title) As String
#If VBA7 Then
    Dim lngModHwnd As LongPtr
#Else
    Dim lngModHwnd As Long
#End If

    Dim lngThreadID As Long
    lngThreadID = GetCurrentThreadId
    lngModHwnd = GetModuleHandle(vbNullString)
    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
    InputBoxDK = InputBox(Prompt, Title)
    UnhookWindowsHookEx hHook
End Function

2- Then change Peter's code as follows:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rDV As Range, rDVChoices As Range, rChanged As Range, rCell As Range
  Dim sPWord As String, sErrors As String

  Set rDV = Columns("G").SpecialCells(xlCellTypeAllValidation)
  Set rChanged = Intersect(Target, rDV)
  If Not rChanged Is Nothing Then
    Application.EnableEvents = False
    Set rDVChoices = Range("C5", Range("C5").End(xlDown))
    For Each rCell In rChanged
      If Len(rCell.Value) > 0 Then
        sPWord = InputBoxDK(Prompt:="Enter password for " & rCell.Value, Title:="Excel")
        If sPWord <> rDVChoices.Find(What:=rCell.Value, MatchCase:=False).Offset(, 1).Value Then
          sErrors = sErrors & vbLf & rCell.Value & "(" & rCell.Address(0, 0) & ")"
          rCell.ClearContents
        End If
      End If
    Next rCell
    Application.EnableEvents = True
    If Len(sErrors) > 0 Then MsgBox "Incorrect password(s) for:" & sErrors, vbOKOnly
  End If
End Sub

 

[cjcass]

Ok, that works great! thank you very much, now I can use the original code from Peter with masked passwords
Thank you both for all your help

 

[Peter_SSs]

Glad you got a successful outcome in the end.

 

[cjcass]

Hello, me again!!
I've been continuing with the development of my workbook and using 'Form Combobox' (rather than an 'in-cell dropdowns') may be a better option for my design. So I have initially set up a form combobox to enable a selection to be made from the original list (C5:C10) which then populates cell G5, with a view to creating a combobox for each cell (G5:G8). Changing the selection in the combobox populates the cell but simply populating the cell doesn't 'fire' the macro. Do you know how I could change the code so it will fire off a combobox change as opposed to an in-cell dropdown?
As always, any help much appreciated.