AW: Bei Fenster Passworteingabe mit "*"
12.12.2018 19:30:02
Sepp
Hallo Thomas,
das geht z. B. so:
Modul Modul1
Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'March 2003
'////////////////////////////////////////////////////////////////////
'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 GetCurrentThreadId Lib "kernel32" () As Long
#If VBA7 Then
Private Declare PtrSafe Function GetClassName Lib "USER32" Alias _
"GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal _
nMaxCount As LongPtr) As Long
#Else
Private Declare Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal _
hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
#End If
'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
Private Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim RetVal, 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
Private Function InputBoxDK(Prompt, Title) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title)
UnhookWindowsHookEx hHook
End Function
Private Sub CommandButton1_Click()
Dim sPassWord As String
sPassWord = InputBoxDK("Paßwort eingeben:", "")
Select Case sPassWord
Case "Passwort"
With Worksheets("Tabelle1")
.Visible = True
.Application.Visible = True
.Select
End With
Case "": Exit Sub
Case Else
Beep
MsgBox "Falsches Passwort eingegeben!"
End Select
Unload Auswahlfenster
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0