带取消功能的 VBA 密码输入

Posted 2023-04-18

【中文标题】带取消功能的 VBA 密码输入

【英文标题】：VBA Password Input with Cancel Function

【发布时间】：2014-01-21 11:07:15

【问题描述】：

我一直在使用 Daniel Klann (http://www.ozgrid.com/forum/showthread.php?t=72794) 编写的标准密码文本框来隐藏密码输入。

主要问题是标准InputBox返回空字段并以同样的方式取消。 Application.InputBox 但是能够在取消时返回 False。

更新 Daniel Klann 的脚本以使用 Application.InputBox 超出了我的能力范围。这将如何实现？

这是丹尼尔的代码：

Option Explicit 

 '////////////////////////////////////////////////////////////////////
 'Password masked inputbox
 'Allows you to hide characters entered in a VBA Inputbox.
 '
 'Code written by Daniel Klann
 'http://www.danielklann.com/
 'March 2003

 '// Kindly permitted to be amended
 '// Amended by Ivan F Moala
 '// http://www.xcelfiles.com
 '// April 2003
 '// Works for Xl2000+ due the AddressOf Operator
 '////////////////////////////////////////////////////////////////////

 '********************   CALL FROM FORM *********************************
 '    Dim pwd As String
 '
 '    pwd = InputBoxDK("Please Enter Password Below!", "Database Administration Security Form.")
 '
 '    'If no password was entered.
 '    If pwd = "" Then
 '        MsgBox "You didn't enter a password!  You must enter password to 'enter the Administration Screen!" _
 '        , vbInformation, "Security Warning"
 '    End If
 '**************************************



 'API functions to be used
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 

 '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 

Private hHook As Long 

Public Function NewProc(ByVal lngCode As Long, _ 
    ByVal wParam As Long, _ 
    ByVal lParam As Long) As Long 

    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 'Class name of the Inputbox
             '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 

 '// Make it public = avail to ALL Modules
 '// Lets simulate the VBA Input Function
Public Function InputBoxDK(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) As String 

    Dim lngModHwnd As Long, lngThreadID As Long 

     '// Lets handle any Errors JIC! due to HookProc> App hang!
    On Error Goto ExitProperly 
    lngThreadID = GetCurrentThreadId 
    lngModHwnd = GetModuleHandle(vbNullString) 

    hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) 
    If Xpos Then 
        InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context) 
    Else 
        InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context) 
    End If 

ExitProperly: 
    UnhookWindowsHookEx hHook 

End Function 

【参考方案1】：

标准InputBox返回空字段并以同样方式取消

不，它没有。它在取消时返回一个空指针 (vbNullString)，为空输入返回一个空字符串 ("")。

Dim s As String
s = InputBox("Test")

If StrPtr(s) = 0 Then
  'Cancel pressed
Else
  'Ok pressed
End If

因为InputBoxDK 返回InputBox 的值不变，所以同样的逻辑适用于它。