Inputbox als Passwortabfrage

[volti]

Hallo,

wer eine Passwortabfrage mit geschützten Zeichen mittels einer Excel-Inputbox machen möchte, kann sich des u.a. Codes bedienen.

Es ist eine Minimalversion mit wenig Code, die lediglich die Eigenschaft der Editbox ändert. Das anzuzeigende Ersatzzeichen, z.B. *, kann freigewählt werden.

PS: Die Application.Inputbox funktioniert diesbezüglich nicht. Ich nehme an, dass die Eigenschaft von der Inputbox selbst wieder verstellt wird.

Code:

Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function SendDlgItemMessageA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
Dim mhTimer As LongPtr

Public Function GetPassword(Optional sPrompt As String = "Bitte geben Sie das Passwort ein!", _
                            Optional sCaption As String = "Passwortabfrage") As String
  mhTimer = SetTimer(0, 0, 25, AddressOf Password_Callback)
  GetPassword = InputBox(sPrompt, sCaption)
End Function

Private Sub Password_Callback()
  If mhTimer <> 0 Then KillTimer 0, mhTimer: mhTimer = 0  ' Timer löschen
'                       ID der Editbox = 4900, &HCC=EM_SETPASSWORDCHAR
  SendDlgItemMessageA GetActiveWindow(), 4900, &HCC, Asc("*"), 0
End Sub

' ###### Aufruf #####
Sub Test()
  MsgBox GetPassword()
End Sub

_________
viele Grüße
Karl-Heinz