Yes I'm sure. Normally the only way to tell what the user has applied with a
dialog is to compare before & after, assuming it returned True. In the case
of a password of course can't do that directly. Actually it's easy enough to
"crack" but probably wouldn't get the original pw, just another one that
works.
OK, if you're feeling adventurous and don't want to roll your own dialog,
have a go with the following. Note the warning about don't do anything in
the VBE while the Timer is running. Run "Test" and adapt that to your
needs, but ensure sufficient error handling is included to stop the timer if
necessary. Probably better not to fiddle with anything else unless you know
what you are doing.
Option Explicit
' get user entered password from the password dialog
' pmbthornton at gmail com
'' <<< DO NOT BREAK OR EDIT ANY CODE WHILE THE TIMER IS RUNNING >>>
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 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 GetWindowText Lib "user32" Alias "GetWindowTextA"
( _
ByVal hWnd As Long, ByVal lpString As String, _
ByVal cch As Long) As Long
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_GETTEXT As Long = &HD
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
Private Const mcDLGNAME As String = "bosa_sdm_XL9"
Private Const mcPROTSHEET As String = "Protect Sheet"
Private Const mcPWCONF As String = "Confirm Password"
Private Const mcUNPROT As String = "Unprotect Sheet"
Private hTimer As Long
Private msPW As String, msPWconfirm As String, msUnprotPW As String
Sub Test()
Dim bProtContOrig As Boolean, bProtCont As Boolean
Dim s, sMsg As String
Dim bApplied As Boolean
Dim ws As Worksheet
On Error GoTo errH
reTry:
Set ws = ActiveSheet
bProtContOrig = ws.ProtectContents
' msPW = "wrong" ' for testing
If bProtContOrig And Len(msPW) Then
If MsgYN("Try password: " & msPW) Then
On Error Resume Next
ws.Unprotect msPW
If ws.ProtectContents Then
MsgBox msPW & vbCr & "invalid password"
Else
MsgBox "unprotected"
Exit Sub
End If
End If
End If
StartLooking
bApplied = Application.Dialogs(xlDialogProtectDocument).Show
StopLooking
bProtCont = ws.ProtectContents
sMsg = "ProtectContents" & vbCr & _
"before <> now " & vbCr & _
bProtContOrig & " <> " & bProtCont & vbCr & vbCr
If bApplied Then
sMsg = sMsg & "msPW = " & msPW & vbCr & _
"msPWconfirm = " & msPWconfirm & vbCr & _
"msUnprotPW = " & msUnprotPW
Else: sMsg = sMsg & "User cancelled"
End If
MsgBox sMsg
Exit Sub
errH:
s = msUnprotPW
StopLooking
If Err.Number = 1004 And Len(s) Then
If MsgYN(s & vbCr & "Incorrect password, try again ?") Then Resume
reTry
Else
MsgBox Err.Description
End If
End Sub
Function MsgYN(sMsg, Optional sTitle As String) As Boolean
On Error Resume Next
If Len(sTitle) = 0 Then sTitle = Application.Name
MsgYN = MsgBox(sMsg, vbYesNo, sTitle) = vbYes
End Function
Sub StartLooking()
msPW = ""
msPWconfirm = ""
msUnprotPW = " " ' yes a space
StopLooking
hTimer = SetTimer(0&, 0&, 30&, AddressOf TimerLookAtDlg)
End Sub
Sub StopLooking()
If hTimer Then
KillTimer 0, hTimer
hTimer = 0
End If
End Sub
Sub TimerLookAtDlg(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Dim hWndDlg As Long, hWndEditPW As Long
Dim nSize As Long, nLen As Long, n As Long
Dim sBuff As String * 128, sEditText As String
Static RunCnt As Long
On Error GoTo errH
hWndDlg = FindWindow(mcDLGNAME, vbNullString)
RunCnt = RunCnt + 1
If RunCnt > 1000 Then Err.Raise 12345
If hWndDlg > 0 Then
GetWindowText hWndDlg, sBuff, 128&
If InStr(1, sBuff, mcPROTSHEET) Then
n = 1
ElseIf InStr(1, sBuff, mcPWCONF) Then
n = 2
ElseIf InStr(1, sBuff, mcUNPROT) Then
n = 3
End If
If n Then
RunCnt = 0
hWndEditPW = FindWindowEx(hWndDlg, 0&, "EDTBX", vbNullString)
nSize = SendMessage(hWndEditPW, WM_GETTEXTLENGTH, 0&, ByVal 0&)
+ 1
If nSize > 1 Then
sEditText = String(nSize, 0)
nLen = SendMessage(hWndEditPW, WM_GETTEXT, nSize, ByVal
sEditText)
If nLen Then
sEditText = Left$(sEditText, nLen)
If n = 1 Then
msPW = sEditText
ElseIf n = 2 Then
msPWconfirm = sEditText
ElseIf n = 3 Then
msUnprotPW = sEditText
End If
End If
End If
End If
End If
Exit Sub
errH:
RunCnt = 0
KillTimer 0, hTimer
If Err.Number = 12345 Then
MsgBox "TimerLookAtDlg timed out while PW dialog not found"
Else
MsgBox Err.Number & " " & Err.Description, , "Error in
TimerLookAtDlg"
End If
End Sub
This is only lightly tested but would be interested in feedback.
Regards,
Peter T
