Attribute VB_Name = "t_AP7_PasswordMask_150113"
Option Explicit
Option Private Module
'mc84excel Updated 20130617 - 64 bit compatible
'mc84excel Updated 20140204 - Error labels
'////////////////////////////////////////////////////////////////////
'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
'////////////////////////////////////////////////////////////////////
'API functions to be used
#If VBA7 And Win64 Then
Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook _
As LongPtr, ByVal ncode As LongLong, ByVal wParam As LongLong, lParam As _
Any) As LongLong
Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias _
"GetModuleHandleA" (ByVal lpModuleName As String) As LongLong
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias _
"SetWindowsHookExA" (ByVal idHook As LongLong, ByVal lpfn As LongPtr, ByVal _
hmod As LongPtr, ByVal dwThreadId As LongLong) As LongLong
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal _
hHook As LongPtr) As LongLong
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 LongPtr) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As _
LongLong
Private hHook As LongPtr
#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
Private hHook As Long
#End If
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR As Long = &HCC
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const HC_ACTION As Long = 0
'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function
Public Function InputBoxDK(ByRef Prompt As String, _
Optional ByRef Title As String, _
Optional ByRef Default As String, _
Optional ByRef Xpos As Long, _
Optional ByRef Ypos As Long, _
Optional ByRef Helpfile As String, _
Optional ByRef Context As Long _
) As String
#If VBA7 And Win64 Then
Dim lngModHwnd As LongLong
Dim lngThreadID As LongLong
#Else
Dim lngModHwnd As Long
Dim lngThreadID As Long
#End If
'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error GoTo ErrHandler
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
ExitProcedure:
UnhookWindowsHookEx hHook
Exit Function
ErrHandler:
Resume ExitProcedure
End Function
#If VBA7 And Win64 Then
Private Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As LongLong
#Else
Private Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
#End If
Dim RetVal As Variant
Dim strClassName As String
Dim 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
Bookmarks