问题描述
我在Excel中创建了以下宏。如果您知道密码,则可以访问下拉列表的某些部分。唯一的问题是输入密码时文本是可见的。
如何使密码中的字符不只是*或点?
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
解决方法
您正在寻找以下功能。请阅读我对此帖子的回答。 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 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 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,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
将此功能声明给模块后,调用如下功能。
Sub MaskedPassword()
Debug.print PasswordBox("Enter your password.","Paasword")
End Sub
最后对您的代码采用功能...
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