星号隐藏输入内容的密码输入

nothingwmm · 发表于 2011-2-18 09:51

本帖最后由 nothingwmm 于 2011-2-18 09:51 编辑

QQ截图未命名.jpg

Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'////////////////////////////////////////////////////////////////////
'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
Sub HiddenPassword()
' Pages 356-358
If InputBoxDK("Please enter password", "Password Required") <> "password" Then
MsgBox "Sorry, that was not a correct password."
Else
MsgBox "Correct Password! Come on in."
End If
End Sub
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
Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _
Optional YPos, Optional HelpFile, Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
On Error Resume Next
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function

复制代码

nothingwmm · 发表于 2011-2-18 10:26

无爱无恨发表于 2011-2-18 10:09
楼主白设了金币购买，俺去点“复制代码”，就省了3BB啊，不过还是要感谢下楼主。

呵呵，算你聪明，我知道！
如果你调试不出来，或者懒的复制，就用金币购买吧，我的所有代码都是全部给出来，你完全可以选择买或者不买，如果你买了就是给我的鼓励，如果不买，给我添个评分也是可以的，如果你什么也不做，我也不介意。所以很自由的哦，大家想怎么弄都可以，我很开放的。我不设置门槛的。代码完全公开！

阿童木 · 发表于 2011-2-18 11:22

另一种方法

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'timeSetEvent函数请参考:http://msdn2.microsoft.com/en-us/library/ms713423.ASPx
Private Declare Function timeSetEvent Lib "winmm.dll" (ByVal uDelay As Long, ByVal uResolution As Long, _
ByVal lpFunction As Long, ByVal dwUser As Long, ByVal uFlags As Long) As Long
Private Declare Function timeKillEvent Lib "winmm.dll" (ByVal uID As Long) As Long
Private Const EM_SETPASSWORDCHAR = &HCC
Dim lTimeID As Long 'Timer ID
Const pswdInputBoxTitle = "密码输入" '输入密码的对话框标题
'TimeProc callback 函数请参考:http://msdn2.microsoft.com/en-us/library/ms713420.aspx
Sub TimeProc(ByVal uID As Long, ByVal uMsg As Long, ByVal dwUser As Long, _
ByVal dw1 As Long, ByVal dw2 As Long)
Dim hwd As Long '输入密码的对话框句柄
'VBA InputBox对话框之Class Name是 "#32770",
'标题为 "pswdInputBox", 这是在InputBox函数的Title引述中自订的
'请注意Application.InputBox方法所出现的对话框Class Name是 "bosa_sdm_XL9"
hwd = FindWindow("#32770", pswdInputBoxTitle)
If hwd <> 0 Then '若对话框存在
'取得输入的文字框句柄, 该文字框的Class Name是"Edit", 无标题,
'而Application.InputBox方法所出现的对话框之文字框的Class Name是"EDTBX"
hwd = FindWindowEx(hwd, 0, "Edit", vbNullString)
'设定密码字符为 "*", "*"的ASCII码为42
SendMessage hwd, EM_SETPASSWORDCHAR, 42, 0
'设定完成, 取消定时器
timeKillEvent lTimeID
End If
End Sub
'自定义函数pswdInputBox, 是一个输入密码使用的InputBox, 输入的内容都以 "*" 显示.
Function pswdInputBox() As Variant
'启动一个特定的Timer事件, 0.01秒延迟, 0.05秒看一次
lTimeID = timeSetEvent(10, 50, AddressOf TimeProc, 1, 1)
'显示InputBox对话框
pswdInputBox = InputBox(Prompt:="请输入编辑密码", Title:=pswdInputBoxTitle)
End Function
Sub Main()
If pswdInputBox <> 123456 Then
MsgBox "密码错误!"
Else
MsgBox "密码正确!"
End If
End Sub

复制代码

西安专家 · 发表于 2011-2-18 11:35

向高手学习

guoguo0001 · 发表于 2012-1-25 00:20

谢谢了，辛苦你了，终于找到了

YANG6815475 · 发表于 2012-1-25 16:35

所以很自由的哦，大家想怎么弄都可以，我很开放的。我不设置门槛的。代码完全公开！

很欣赏楼主的性格！值得学习！也应加分。
.

YANG6815475 · 发表于 2012-1-25 20:58

不知你的代码有什么用？！Excel安全性密码输入也是星※※号，看不见数字的！

YANG6815475 · 发表于 2012-1-29 14:17

不知楼主的东西有什么用！？怎么用？
先下载复制，不知何用？又花金币下载来看，也不知有什么用？！

建议有这类东西的各位在发帖之前，检查一下有无错误，或者用例子检验一下对否？！经检查无误后再发表出来，以免浪费大家的时间和精力！

liziyuliziyu7 · 发表于 2012-2-16 22:25

的顶顶顶顶顶顶顶顶顶顶顶顶顶顶顶顶顶顶

mmqq12345678 · 发表于 2013-1-14 17:17

无分！！！！！！！

		自动登录	找回密码
密码			注册

[分享] 星号隐藏输入内容的密码输入

评分

评分

评分