Last active
February 16, 2018 00:54
-
-
Save iizukak47/bff0a589eda1081a04ad084842c039ab to your computer and use it in GitHub Desktop.
【VBA】InputBoxDK(パスワード入力用のマスキング対応InputBox関数)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'############################################################################## | |
'[モジュール名] InputBoxDK | |
'[概要] マスキング対応InputBox関数 | |
'############################################################################## | |
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () 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 GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, _ | |
ByVal lpClassName As String, _ | |
ByVal nMaxCount 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 CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, _ | |
ByVal ncode As LongPtr, ByVal wParam As LongPtr, lParam As Any) 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 InputBoxDK(Prompt, Optional title, Optional Default, Optional XPos, _ | |
Optional YPos, Optional HelpFile, Optional Context) As String | |
Dim lngThreadID As LongPtr, lngModHwnd As LongPtr | |
lngThreadID = GetCurrentThreadId | |
lngModHwnd = GetModuleHandle(vbNullString) | |
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) | |
InputBoxDK = InputBox(Prompt, title, Default, XPos, YPos, HelpFile, Context) | |
UnhookWindowsHookEx hHook | |
End Function | |
Private 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 '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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Public Function InputBoxSample() | |
Dim pw As String | |
pw = InputBoxDK("パスワードを入力してください。", "パスワード") | |
End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment