Sunday, 18 January 2015

Asterisk the Galling: Using The VBA InputBox() For Passwords

Using the VBA InputBox for passwords and hiding the user's keyboard input with asterisks.



This is another horrible hack, born from a requirement to stop storing Excel sheet and workbook passwords in the worksheets themselves, in the interests of security.

Experienced Excel developers, power users, IT security experts, and preserved rat brains floating in jars of formaldehyde might *just* be capable of reasoning-out one or two minor inconsistencies lurking in the logic of that statement.

However, I've still got to do it. And I can either create a VBA form and hope that the 'Password Chars' method exposed by some (but not all) textbox controls is reliable and secure, and can't be switched off by clever but misguided users; or just type the password into a standard VBA.Interaction InputBox() function.

Unfortunately, the InputBox function doesn't have a 'PasswordChars' option. So here's the simple and straightforward VBA code to do that, with the necessary API functions declared for both 64- and 32-bit environments:

Option Explicit #If VBA7 And Win64 Then    ' 64 bit Excel under 64-bit windows   ' Use LongLong and LongPtr     Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _                                     (ByVal hWnd1 As LongPtr, _                                      ByVal hWnd2 As LongPtr, _                                      ByVal lpsz1 As String, _                                      ByVal lpsz2 As String _                                      ) As LongPtr     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _                                     (ByVal lpClassName As String, _                                      ByVal lpWindowName As String) As LongPtr     Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _                                     (ByVal hwnd As LongPtr, _                                      ByVal wMsg As Long, _                                      ByVal wParam As Long, _                                      ByRef lParam As Any _                                      ) As LongPtr     Private Declare PtrSafe Function SetTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As LongPtr, _                                      ByVal uElapse As Long, _                                      ByVal lpTimerFunc As LongPtr _                                      ) As Long      Public Declare PtrSafe Function KillTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As LongPtr _                                      ) As Long      #ElseIf VBA7 Then     ' 64 bit Excel in all environments  ' Use LongPtr only, LongLong is not available     Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _                                     (ByVal hWnd1 As LongPtr, _                                      ByVal hWnd2 As LongPtr, _                                      ByVal lpsz1 As String, _                                      ByVal lpsz2 As String _                                      ) As LongPtr     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _                                     (ByVal lpClassName As String, _                                      ByVal lpWindowName As String) As LongPtr     Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _                                     (ByVal hwnd As LongPtr, _                                      ByVal wMsg As Long, _                                      ByVal wParam As Long, _                                      ByRef lParam As Any _                                      ) As LongPtr     Private Declare PtrSafe Function SetTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As Long, _                                      ByVal uElapse As Long, _                                      ByVal lpTimerFunc As LongPtr) As LongPtr     Private Declare PtrSafe Function KillTimer Lib "user32" _                                     (ByVal hwnd As LongPtr, _                                      ByVal nIDEvent As Long) As Long #Else    ' 32 bit Excel     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 FindWindow Lib "user32" Alias "FindWindowA" _                             (ByVal lpClassName As String, _                              ByVal lpWindowName As String) As Long     Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _                             (ByVal hwnd As Long, _                              ByVal wMsg As Long, _                              ByVal wParam As Long, _                              ByRef lParam As Any _                              ) 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     Public Declare Function KillTimer Lib "user32" _                             (ByVal hwnd As Long, _                              ByVal nIDEvent As Long) As Long #End If Private Const PASSBOX_INPUT_CAPTION As String = "Password Required" Private Const EM_SETPASSWORDCHAR    As Long = &HCC Private Const NV_INPUTBOX           As Long = &H5000& Public Function InputBoxPassword(Prompt As String, _                                  Optional Default As String = vbNullString, _                                  Optional XPos, Optional YPos, _                                  Optional HelpFile, Optional HelpContext _                                  ) As String On Error Resume Next ' Replicates the functionality of a VBA InputBox function, with the user's ' typed input displayed as asterisks. The 'Title' parameter for the dialog ' caption is hardcoded as "Password Required" in this implementation. ' REQUIRED function: TimerProcInputBox ' REQUIRED API declarations: FindWindow, FindWindowEx, SetTimer, KillTimer ' Nigel Heffernan, January 2015, HTTP://Excellerando.Blogspot.com ' **** **** **** *** THIS CODE IS IN THE PUBLIC DOMAIN **** **** **** **** ' Based on code posted by user 'manish1239' in Xtreme Visual Basic Talk in ' October 2003 http://www.xtremevbtalk.com/archive/index.php/t-112708.html ' Coding notes: we send the 'Set PasswordChar' message to the textbox edit ' window in the VBA 'InputBox' dialog.  This isn't a straightforward task: ' InputBox is synchronous, a 'Modal Dialog' which leaves our application's ' VBA code in a waiting state at the exact moment we need to call the Send ' Message API function. So it runs by a delayed callback from an API Timer ' Warning: many of the 64-bit API declarations posted online are incorrect ' and *none* of them are correct for the pointer-safe Timer API Functions. On Error Resume Next SetTimer 0&, 0&, 10&, AddressOf TimerProcInputBox InputBoxPassword = InputBox(Prompt, _                             PASSBOX_INPUT_CAPTION, _                             Default, _                             XPos, YPos, _                             HelpFile, HelpContext) End Function #If VBA7 And Win64 Then     ' 64 bit Excel under 64-bit windows  ' Use LongLong and LongPtr                             ' Note that wMsg is always the WM_TIMER message, which fits in a Long     Public Sub TimerProcInputBox(ByVal hwnd As LongPtr, _                                  ByVal wMsg As Long, _                                  ByVal idEvent As LongPtr, _                                  ByVal dwTime As LongLong)     On Error Resume Next                               ' REQUIRED for Function InputBoxPassword     ' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx          KillTimer hWndIbox, idEvent          Dim hWndIbox As LongPtr   ' Handle to VBA InputBox            hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0, "Edit", "")          If hWndIbox <> 0 Then         SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&     End If              End Sub      #ElseIf VBA7 Then          ' 64 bit Excel in all environments   ' Use LongPtr only     Public Sub TimerProcInputBox(ByVal hwnd As LongPtr, _                                  ByVal wMsg As Long, _                                  ByVal idEvent As LongPtr, _                                  ByVal dwTime As Long)     On Error Resume Next                               ' REQUIRED for Function InputBoxPassword     ' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx          Dim hWndIbox As LongPtr    ' Handle to VBA InputBox          KillTimer hwnd, idEvent          hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0, "Edit", "")                If hWndIbox <> 0 Then         SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&     End If                       End Sub      #Else    ' 32 bit Excel     Public Sub TimerProcInputBox(ByVal hwnd As Long, _                                  ByVal wMsg As Long, _                                  ByVal idEvent As Long, _                                  ByVal dwTime As Long)     On Error Resume Next          ' REQUIRED for Function InputBoxPassword     ' https://msdn.microsoft.com/en-US/library/windows/desktop/ms644907(v=vs.85).aspx          Dim hWndIbox As Long    ' Handle to VBA InputBox          KillTimer hwnd, idEvent            hWndIbox = FindWindowEx(FindWindow("#32770", PASSBOX_INPUT_CAPTION), 0&, "Edit", "")          If hWndIbox <> 0 Then         SendMessage hWndIbox, EM_SETPASSWORDCHAR, Asc("*"), 0&     End If                       End Sub #End If


Share and enjoy.

No comments:

Post a comment