Inputbox für Passwörter

Eingabe von Passwörtern in Inputbox

Mit einer schnöden User-Form und darauf einer Textbox lässt sich das recht einfach lösen. Es geht aber auch etwas schöner, leider auch weitaus komplizierter mit einer echten Inputbox.

Ürsprünglich wurde die erweiterte Inputbox im Jahr 2002 noch unter Excel 97 entwickelt. Nun bleibt die Zeit aber nicht stehen und Excel 97 weilt nur noch selten unter uns. Man könnte nun einfach die AddressOf-Nachbildung rausschmeißen, was bei neueren Versionen dann keine Fehlermeldung mehr bringt.

Ich habe aber nun die neue Version komplett überarbeitet, so dass man nun auch die Texte der Buttons ändern kann. Außerdem kann eine Timeoutzeit übergeben werden, nach der der Dialog mit dem Betätigen eines vorher angegebenen Buttons beendet wird. Die alte Version findet man nun am Ende dieser Seite.

Es werden nun Hooks verwendet. Wie immer bei Subclassing, Hooks und Co. sind Haltepunkte, Syntaxfehler und nicht behandelte Laufzeitfehler in den aufgerufenen Prozeduren fast immer tödlich für die Anwendung. Meist hilft dann nur noch ein Abschießen des Prozesses, nach Änderungen deshalb vor dem Starten immer schön sichern.

Beispieldatei inputboxEx.zip 64 kB

Option Explicit
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 CallNextHookEx _
   Lib "user32" ( _
   hHook As Long, _
   ncode As Long, _
   wParam As Long, _
   lParam As Long _
   ) As Long
Private Declare Function UnhookWindowsHookEx _
   Lib "user32" ( _
   ByVal hHook As Long _
   ) As Long
Private Declare Function GetCurrentThreadId _
   Lib "kernel32" () As Long
Private Declare Function SetDlgItemText _
   Lib "user32" Alias "SetDlgItemTextA" ( _
   ByVal hDlg As Long, _
   ByVal nIDDlgItem As Long, _
   ByVal lpString As String _
   ) 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 SetTimer _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   ByVal nIDEvent As Long, _
   ByVal uElapse As Long, _
   ByVal lpTimerFunc As Long _
   ) As Long
Private Declare Function KillTimer _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   ByVal nIDEvent As Long _
   ) As Long
Private Declare Function PostMessage _
   Lib "user32" Alias "PostMessageA" ( _
   ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long _
   ) As Long

Private Const SC_CLOSE           As Long = &HF060&
Private Const WM_LBUTTONDOWN     As Long = &H201
Private Const WM_LBUTTONUP       As Long = &H202
Private Const WM_SYSCOMMAND      As Long = &H112
Private Const EM_SETPASSWORDCHAR As Long = &HCC

Private Const WH_CBT             As Long = 5
Private Const HC_ACTION          As Long = 0
Private Const HCBT_ACTIVATE      As Long = 5

Private mstrOk                   As String
Private mstrCancel               As String
Private mlngChar                 As Long
Private mlngHookInput            As Long
Private mlngHandleInput          As Long
Private mlngTimerInput           As Long

Private mlngButton               As Long

Private Sub TestInput()
   MsgBox InputBoxXL(Prompt:="Prompt", Title:="Title", _
      Default:="Default", _
      XPos:=1000, YPos:=5000, _
      TextOk:="Eingabe &Ok", TextCancel:="&Exit", _
      PassChar:="#", _
      TimeoutSec:=10, TimeoutID:=vbCancel)
End Sub

Public Function InputHookProc( _
   ByVal uMsg As Long, _
   ByVal wParam As Long, _
   ByVal lParam As Long _
   ) As Long
   Dim strClass   As String
   Dim lngRet     As Long

   If uMsg < HC_ACTION Then
       InputHookProc = CallNextHookEx(mlngHookInput, uMsg, wParam, lParam)
       Exit Function
   End If

   If uMsg = HCBT_ACTIVATE Then
      strClass = String(255, 0)
      lngRet = GetClassName(wParam, strClass, Len(strClass))
      If Left(strClass, lngRet) = "#32770" Then
         mlngHandleInput = wParam
         If mstrOk <> "" Then
            SetDlgItemText wParam, vbOK, mstrOk
         End If
         If mstrCancel <> "" Then
            SetDlgItemText wParam, vbCancel, mstrCancel
         End If
         SendDlgItemMessage wParam, 4900&, EM_SETPASSWORDCHAR, mlngChar, 0&
         ' Hook aufheben
         UnhookWindowsHookEx mlngHookInput
      End If
   End If

   InputHookProc = CallNextHookEx(mlngHookInput, uMsg, wParam, lParam)

End Function

Public Function InputBoxXL( _
   Prompt As String, _
   Optional Title As String = "Microsoft Excel", _
   Optional Default As String, _
   Optional XPos As Long = -100, _
   Optional YPos As Long = -100, _
   Optional HelpFile As String, _
   Optional Context As Long, _
   Optional TextOk As String, _
   Optional TextCancel As String, _
   Optional PassChar As String = "*", _
   Optional TimeoutSec As Long, _
   Optional TimeoutID As Long _
   ) As String

   Dim lngHwnd          As Long
   Dim lngInstance      As Long
   Dim lngThread        As Long

   On Error Resume Next

   ' Modulweite Variablen zurücksetzen
   mlngHandleInput = 0: mlngHookInput = 0: mlngTimerInput = 0

   mstrOk = TextOk
   mstrCancel = TextCancel
   mlngChar = Asc(Left(PassChar, 1))
   lngInstance = Application.hInstance
   lngThread = GetCurrentThreadId()

   If TimeoutSec > 0 Then
      mlngButton = TimeoutID
      TimeoutSec = TimeoutSec * 1000
      ' Timer Timeout initialisieren
      mlngTimerInput = SetTimer(0, 0, TimeoutSec, AddressOf TimerProcInput)
   End If

   mlngHookInput = SetWindowsHookEx(WH_CBT, _
      AddressOf InputHookProc, lngInstance, lngThread)

   If mlngHookInput <> 0 Then
      ' Nach meinen Tests müssen beide, die X- und die Y-Pos
      ' angegeben werden, damit eine benutzerdef. Position
      ' übernommen wird!
      ' Lt OH. : Wenn Sie xpos nicht angeben, wird das Dialogfeld
      ' horizontal zentriert. Wenn Sie ypos nicht angeben, wird
      ' das Dialogfeld etwa ein Drittel unterhalb des oberen
      ' Bildschirmrands (bezogen auf die gesamte Bildschirmhöhe)
      ' angezeigt.
      If (YPos = -100) And (YPos = -100) Then
         InputBoxXL = InputBox(Prompt, _
            Title, Default, , , HelpFile, Context)
      ElseIf XPos = -100 Then
         InputBoxXL = InputBox(Prompt, _
            Title, Default, , YPos, HelpFile, Context)
      ElseIf YPos = -100 Then
         InputBoxXL = InputBox(Prompt, _
            Title, Default, XPos, , HelpFile, Context)
      Else
         InputBoxXL = InputBox(Prompt, _
            Title, Default, XPos, YPos, HelpFile, Context)
      End If
   End If

   ' Timer löschen
   KillTimer 0, mlngTimerInput

End Function

Public Function TimerProcInput( _
   ByVal hwnd As Long, _
   ByVal Msg As Long, _
   ByVal idEvent As Long, _
   ByVal dwTime As Long)

   ' Timer löschen
   KillTimer 0, mlngTimerInput

   ' Messagebox schließen
   InputboxClose

End Function

Private Sub InputboxClose()
   On Error Resume Next

   If mlngHandleInput = 0 Then Exit Sub

   If (mlngButton < 1) Or (mlngButton > 2) Then
      ' Fenster ohne Betätigung eines Buttons schließen
      ' Aber nur, wenn man auch einen Abbrechen-Button
      ' oder ein entsprechendes Systemmenü hat
      PostMessage mlngHandleInput, WM_SYSCOMMAND, SC_CLOSE, 0
   Else
      SendDlgItemMessage mlngHandleInput, mlngButton, WM_LBUTTONDOWN, 0&, 0&
      SendDlgItemMessage mlngHandleInput, mlngButton, WM_LBUTTONUP, 0&, 0&
   End If
End Sub

Version XL97

Die wichtigste Funktion ist dabei die zur Ermittlung eines Funktionszeigers. Ab XL2000 gibt es AdressOf, was die ganze Sache enorm vereinfacht. Dank K. Getz und M. Kaplan kann man das unter Office 97 nachbilden.
Der Trick, um aus einer Inputbox eine für die Passwortabfrage zu machen, ist der asynchrone Aufruf einer Funktion über einen Windows-Timer. Der Timer muss aber vor dem Anzeigen der Inputbox gestartet werden, denn die Programmausführung stoppt solange, bis die Inputbox verschwunden ist. In der Timer-Proc wird dann das Handle der Inputbox gesucht und an das Fenster eine Message gesendet, die den Stil ändert. Auch andere Ersatzzeichen als der Stern sind möglich. Man kann den Code von 4 und 5 auch noch etwas kürzen, indem man beispielsweise FindWindowEx() einsetzt, das vorliegende hatte ich aber schon in der Schublade liegen und war ganz einfach zu faul, es nochmal zu überarbeiten. In VB würde man das mit einem Hook erledigen, das funzt aber nicht so richtig in Office.

Beispieldatei inputbox.zip 16 k

'*************************************
'* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
'*************************************

Private Declare Function GetVbaProjekt _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hVBA As Long) As Long

Private Declare Function GetFunktionsnummerString _
Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hVBA As Long, ByVal strFuncNameUnicode _
As String, strFunktionsnummer As String) As Long

Private Declare Function GetFunktionsnummerLong _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _

(ByVal hVBA As Long, ByVal strFunktionsnummer _
As String, hlngFunction As Long) As Long

'*************************************
'* Der Rest ist von mir
'*************************************

Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc _
As Long) As Long

Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

'************************************

Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Private Declare Function GetWindow Lib "user32" _
(ByVal hwnd As Long, ByVal wCmd 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 GetWindowText Lib "user32" _
Alias "GetWindowTextA" (ByVal hwnd As Long, _
ByVal lpString As String, ByVal cch As Long) _
As Long

Private Declare Function SendMessageBynum& Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal _
wMsg As Long, ByVal wParam As Long, ByVal lParam _
As Long)

Private Const EM_SETPASSWORDCHAR = &HCC
Private Const GW_CHILD = 5
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2

'************************************

Private hlngTimerKennung As Long

Public Function PasswortHolen(Optional Beschriftung As String) As String
If Beschriftung = "" Then Beschriftung = "Geben sie ihr Passwort ein!"
TimerSetzen
PasswortHolen = InputBox(Beschriftung)
End Function

Private Sub Passwortchar()
Dim hwnd&, hwnd1&, lngRück&, Klasse$
Dim Stil As Long
hwnd = FindWindow("#32770", "Microsoft Excel")
hwnd1 = GetWindow(hwnd, GW_CHILD)
Do
Klasse = String(255, 0)
lngRück = GetClassName(hwnd1, Klasse, 250)
Klasse = Left$(Klasse, InStr(1, Klasse, _
Chr(0)) - 1)
If LCase(Klasse) = "edit" Then
SendMessageBynum hwnd1, _
EM_SETPASSWORDCHAR, 42, 0
End If
hwnd1 = GetWindow(hwnd1, GW_HWNDNEXT)
Loop While hwnd1 <> 0
End Sub

Private Sub TimerSetzen()
hlngTimerKennung = SetTimer(0, 0, 1000, _
GetFuncAdress("ApiTimer1"))
If hlngTimerKennung = 0 Then MsgBox _
"Fehler beim Initialisieren des Timers"
End Sub

Private Sub TimerZerstören()
If hlngTimerKennung <> 0 Then _
KillTimer 0, hlngTimerKennung
End Sub

Private Sub ApiTimer1(ByVal hwndOwner&, _
ByVal lngWindowMessage&, _
ByVal hlngRückTimerKennung&, _
ByVal lngTickCount&)
TimerZerstören
Passwortchar
End Sub

'*************************************
'* AddressOf
'* Ausgeknobelt von K. Getz und M. Kaplan
'*************************************

Public Function GetFuncAdress&(strFunktion$)
Dim hVBA&, lngRück&, strFunktionsnummer$
Dim hlngFunction&, strFuncNameUnicode$
strFuncNameUnicode = StrConv(strFunktion, vbUnicode)
GetVbaProjekt hVBA
If hVBA <> 0 Then
lngRück = GetFunktionsnummerString(hVBA, _
strFuncNameUnicode, strFunktionsnummer)
If lngRück = 0 Then
lngRück = GetFunktionsnummerLong(hVBA, _
strFunktionsnummer, hlngFunction)
If lngRück = 0 Then GetFuncAdress = _
hlngFunction
End If
End If
End Function