Project locked for viewing - SendKeys?

[theta]

Hi all...I have almost finished a project (thanks to snd for help) but I have come across a small issue. I have around 35 projects in the VBE that are locked for viewing.

I have been looking at the sendkeys method to unlock a project - but these are all for editing (not when locked for viewing).

I have sendkeys and would not like to use it, but with active window control it shouldn't be too bad.

I need to get the solid reference command to get to Tools > VBAProject properties

e.g.
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute

Where would I get the FindControl ID for this menu?

I then need to check if the returned or active window is the 'vbaProj Password' windows > if TRUE then locked for viewing, need the sendkeys to enter password and unlock.

Any help appreciated...

1. Get the Commandbars ID for the vbaProj Properties
2. Detect if new active window is prompt
3. Send keys with "password"

I can then continue on with the unprotect and run my project ...

[snb]

You'd better unlock them manually.

[theta]

Hmm I have almost finished the code. Just need a way to catch an active window?

When I use vbaProj.VBE.ActiveWindow.Caption I get :

"Project - My Project Name"

When in fact the active window is quite clearly a dialog box prompting for password entry.

How to I capture the active dialog box?

[Kenneth Hobs]

Focus and timing are big issues with SendKeys() methods. Of course UAC must be off for it to work.

Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Sub Test_GetWindText()
MsgBox GetWindText(GetFocus)
MsgBox GetWindText(GetForegroundWindow)
End Sub

Function GetWindText(hwnd As Long)
Dim MyStr As String
'Create a buffer
MyStr = String(100, Chr$(0))
'Get the windowtext
GetWindowText hwnd, MyStr, 100
'strip the rest of buffer
MyStr = Left$(MyStr, InStr(MyStr, Chr$(0)) - 1)
GetWindText = MyStr
End Function

[Aflatoon]

Based on an old post at standards.com, you might try this:

Option Explicit


Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetWindow Lib "user32" ( _
ByVal hWnd As Long, ByVal uCmd As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" ( _
ByVal hWnd As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const GW_CHILD = 5
Public Const WM_CLOSE = &H10
Public Const WM_SETTEXT = &HC
Public Const WM_GETTEXT = &HD
Public Const BM_GETCHECK = &HF0&
Public Const BM_SETCHECK = &HF1&
Public Const BST_CHECKED = &H1&
Public Const EM_REPLACESEL = &HC2
Public Const EM_SETSEL = &HB1
Public Const BM_CLICK = &HF5&
Public Const TCM_SETCURFOCUS = &H1330&

Private Const TimeoutSecond = 2

Private g_ProjectName As String
Private g_Password As String
Private g_hwndVBE As Long
Private g_Result As Long
Private g_hwndPassword As Long


Public Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim hwndProjectProp As Long, hwndProjectProp2 As Long
Dim hwndTab As Long, hwndLockProject As Long, hwndPassword As Long
Dim hwndConfirmPassword As Long, hwndOK As Long
Dim hwndtmp As Long, lRet As Long
Dim IDTab As Long, IDLockProject As Long, IDPassword As Long
Dim IDConfirmPassword As Long, IDOK As Long
Dim sCaption As String
Dim timeout As Date, timeout2 As Date
Dim pwd As String

On Error GoTo ErrorHandler
KillTimer 0, idEvent
IDTab = &H3020&
IDLockProject = &H1557&
IDPassword = &H155E&
IDConfirmPassword = &H1556&
IDOK = &H1&
sCaption = " Password"

'for the japanese version
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1041
sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
End Select

sCaption = g_ProjectName & sCaption
Debug.Print sCaption
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout

hwndProjectProp = 0
hwndProjectProp2 = 0
hwndTab = 0
hwndLockProject = 0
hwndPassword = 0
hwndConfirmPassword = 0
hwndOK = 0

hwndtmp = 0
Do
hwndtmp = FindWindowEx(0, hwndtmp, vbNullString, sCaption)
If hwndtmp = 0 Then Exit Do
Loop Until GetParent(hwndtmp) = g_hwndVBE
If hwndtmp = 0 Then GoTo Continue
Debug.Print "found window"
lRet = SendMessage(hwndtmp, TCM_SETCURFOCUS, 1, ByVal 0&)

hwndPassword = GetDlgItem(hwndtmp, IDPassword)
Debug.Print "hwndpassword: " & hwndPassword
' hwndConfirmPassword = GetDlgItem(hwndProjectProp2, IDConfirmPassword)
hwndOK = GetDlgItem(hwndtmp, IDOK)
Debug.Print "hwndOK: " & hwndOK
If (hwndtmp _
And hwndOK) = 0 Then GoTo Continue

lRet = SetFocusAPI(hwndPassword)
lRet = SendMessage(hwndPassword, EM_SETSEL, 0, ByVal -1&)
lRet = SendMessage(hwndPassword, EM_REPLACESEL, 0, ByVal g_Password)

pwd = String(260, Chr(0))
lRet = SendMessage(hwndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
If pwd <> g_Password Then GoTo Continue


lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

g_Result = 1
Exit Do

Continue:
DoEvents
Sleep 100
Loop
' Exit Function

ErrorHandler:
If hwndPassword <> 0 Then SendMessage hwndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function



Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
Dim timeout As Date
Dim lRet As Long

On Error GoTo ErrorHandler
UnlockProject = 1
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If

g_ProjectName = Project.Name
g_Password = Password
' LockWindowUpdate GetDesktopWindow()
Application.VBE.MainWindow.visible = True
g_hwndVBE = Application.VBE.MainWindow.hWnd
g_Result = 0
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then
GoTo ErrorHandler
End If
Application.VBE.CommandBars.FindControl(ID:=2578).Execute

timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then UnlockProject = 0
AppActivate Application.Caption
LockWindowUpdate 0
Exit Function

ErrorHandler:
AppActivate Application.Caption
LockWindowUpdate 0
End Function

Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "myPassword")
Case 0: MsgBox "The project was unlocked."
Case 2: MsgBox "The active project was already unlocked."
Case Else: MsgBox "Error or timeout."
End Select
End Sub

[theta]

WOW...thanks - all the googling I did failed to unearth that treasure. Thanks for window select script as well, I will be using that ;)

I have been struggling with this semi working code for 2 hours, but will try ^ the above instead :)



Public Sub UnprotectVBProject(ByRef vbaProj As Object, ByVal password As String)

'Check to see if VBA project is already unlocked
If vbaProj.Protection <> 1 Then Exit Sub

Debug.Print vbaProj.Name
Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
DoEvents

SendKeys password, True
SendKeys "{ENTER}", True
SendKeys "{ESC}", True

Debug.Print "Password correct"

'Not the right password
If vbaProj.Protection = 1 Then
Debug.Print "Password incorrect"
SendKeys "%{F11}", True
End If

'Reset Password
password = ""

Set vbaProj = Nothing

End Sub

[theta]

That one doesn't work. Freezes out :/ (Office 2010?)

Do you have an example workbook you can send with working code

[theta]

That one doesn't work. Freezes out :/ (Office 2010?)

Do you have an example workbook you can send with working code


The code works with a few tweaks :)

I just need to modify it so that I can use it for automation. I have put it into a loop but after a project is unlocked, the project properties window stays open.

So you have to ESC that, then click OK on the dialog saying the "Project was unlocked"

Could not see sendkeys in this code, so how would I capture and close the newely opened "VBAProject Properties" window? (the one presented after a correct password) ?





Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetWindow Lib "user32" ( _
ByVal HWnd As Long, ByVal uCmd As Long) As Long
Declare Function GetParent Lib "user32" (ByVal HWnd As Long) As Long
Declare Function GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal HWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" ( _
ByVal HWnd As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function SetTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" ( _
ByVal HWnd As Long, ByVal nIDEvent As Long) As Long

Public Const GW_CHILD = 5
Public Const WM_CLOSE = &H10
Public Const WM_SETTEXT = &HC
Public Const WM_GETTEXT = &HD
Public Const BM_GETCHECK = &HF0&
Public Const BM_SETCHECK = &HF1&
Public Const BST_CHECKED = &H1&
Public Const EM_REPLACESEL = &HC2
Public Const EM_SETSEL = &HB1
Public Const BM_CLICK = &HF5&
Public Const TCM_SETCURFOCUS = &H1330&

Private Const TimeoutSecond = 2

Private g_ProjectName As String
Private g_Password As String
Private g_hwndVBE As Long
Private g_Result As Long
Private g_hwndPassword As Long

Public Function UnlockTimerProc(ByVal HWnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim hwndProjectProp As Long, hwndProjectProp2 As Long
Dim hwndTab As Long, hwndLockProject As Long, hwndPassword As Long
Dim hwndConfirmPassword As Long, hwndOK As Long
Dim hwndtmp As Long, lRet As Long
Dim IDTab As Long, IDLockProject As Long, IDPassword As Long
Dim IDConfirmPassword As Long, IDOK As Long
Dim sCaption As String
Dim timeout As Date, timeout2 As Date
Dim pwd As String

On Error GoTo ErrorHandler
KillTimer 0, idEvent
IDTab = &H3020&
IDLockProject = &H1557&
IDPassword = &H155E&
IDConfirmPassword = &H1556&
IDOK = &H1&
sCaption = " Password"

'for the japanese version
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1041
sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
End Select

sCaption = g_ProjectName & sCaption
Debug.Print sCaption
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout

hwndProjectProp = 0
hwndProjectProp2 = 0
hwndTab = 0
hwndLockProject = 0
hwndPassword = 0
hwndConfirmPassword = 0
hwndOK = 0

hwndtmp = 0
Do
hwndtmp = FindWindowEx(0, hwndtmp, vbNullString, sCaption)
If hwndtmp = 0 Then Exit Do
Loop Until GetParent(hwndtmp) = g_hwndVBE
If hwndtmp = 0 Then GoTo Continue
Debug.Print "found window"
lRet = SendMessage(hwndtmp, TCM_SETCURFOCUS, 1, ByVal 0&)

hwndPassword = GetDlgItem(hwndtmp, IDPassword)
Debug.Print "hwndpassword: " & hwndPassword
' hwndConfirmPassword = GetDlgItem(hwndProjectProp2, IDConfirmPassword)
hwndOK = GetDlgItem(hwndtmp, IDOK)
Debug.Print "hwndOK: " & hwndOK
If (hwndtmp _
And hwndOK) = 0 Then GoTo Continue

lRet = SetFocusAPI(hwndPassword)
lRet = SendMessage(hwndPassword, EM_SETSEL, 0, ByVal -1&)
lRet = SendMessage(hwndPassword, EM_REPLACESEL, 0, ByVal g_Password)

pwd = String(260, Chr(0))
lRet = SendMessage(hwndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
If pwd <> g_Password Then GoTo Continue


lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

g_Result = 1
Exit Do

Continue:
DoEvents
Sleep 100
Loop
' Exit Function

ErrorHandler:
If hwndPassword <> 0 Then SendMessage hwndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function

Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
Dim timeout As Date
Dim lRet As Long

On Error GoTo ErrorHandler
UnlockProject = 1
'If Project.Protection <> vbext_pp_locked Then
If Project.Protection <> 1 Then
UnlockProject = 2
Exit Function
End If

g_ProjectName = Project.Name
g_Password = Password
' LockWindowUpdate GetDesktopWindow()
Application.VBE.MainWindow.Visible = True
g_hwndVBE = Application.VBE.MainWindow.HWnd
g_Result = 0
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then
GoTo ErrorHandler
End If
Application.VBE.CommandBars.FindControl(ID:=2578).Execute

timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then UnlockProject = 0
AppActivate Application.Caption
LockWindowUpdate 0
Exit Function

ErrorHandler:
AppActivate Application.Caption
LockWindowUpdate 0
End Function

Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "password")
Case 0: MsgBox "The project was unlocked."
Case 2: MsgBox "The active project was already unlocked."
Case Else: MsgBox "Error or timeout."
End Select
End Sub

[AirCooledNut]

Subscribed!

If you get this figured out please post the [commented!] code. I thought this couldn't be done and using SendKeys is tricky to say the least. Don't forget to re-lock the project!

[Aflatoon]

That may be an old version of the code as I'm sure I had resolved that. Will try and dig it out when I am back from my travels in a week if it has not been fixed by some kind soul first. :)

[GTO]

EDIT:

I posted text to go with the attachment twice, but either too much or something is goofy. Anyways, here is my shot at it.

@Aflatoon:

Hi there :-) As the OP has been away, I thought I'd wait until he returned, but 'cat-killin' curiousity has gotten the best of me. Did you find your old solution? I too had run into Howard Kaikow's (may he rest in peace) example at http://www.standards.com/Office/SetVBAProjectPassword.html. It must have been some time ago, as I do not recall seeing his sister's notice on the home page.

At least for me, and going off my poor blond memory, I think my prior attempts were trying to run the code in the same instance. For whatever reason, in re-reading Mr. Kaikow's code, it struck me that as he was using VB, Excel was actually seperate, so this time I tried against a seperate instance. Viola! It seems to work. Although probably overly lengthy, and I already spotted a couple of 'not needed' lines, here is what I came up with.

The zip attached contains the primary workbook, three to run against, and a couple of image files. I really got far fancier than needed, as of course only the developer would use this. Anyways, look foreward to seeing what you came up with if you get a chance.

Mark

[theta]

OP is still here :) just waiting on the updated code that auto captures handles / closes the "Project was unlocked" window.

The automation works, but I end up closing this window each time another project is unlocked...

[GTO]

OP is still here :) just waiting on the updated code that auto captures handles / closes the "Project was unlocked" window.

The automation works, but I end up closing this window each time another project is unlocked...

Hi Theta:hi:

I hope you you did not take my verbiage as negative; as I also kept working on it, bit, by tiny bit, whilst waiting. I was also hoping that Aflatoon would post an updated solution, as callbacks (and anything API related really) are, if not a total bafflement, at least an awfully challenging bit to learn.

I am afraid that I do not understand the remainder of your response at all. Could you describe what is happening in better detail? Also, zip a couple of non-data-sensitive files, along with the (presumably) code-changing file, as you have adapted the suggestion.

Thank you so much,

Mark

[Aflatoon]

Couldn't find my old code so have cobbled this together - only lightly tested but I think this should work to dismiss the properties dialog too - there may still be a lot of unnecessary stuff left in there!

Option Explicit
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetWindow Lib "user32" ( _
ByVal hWnd As Long, ByVal uCmd As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" ( _
ByVal hWnd As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const WM_CLOSE = &H10
Public Const WM_GETTEXT = &HD
Public Const EM_REPLACESEL = &HC2
Public Const EM_SETSEL = &HB1
Public Const BM_CLICK = &HF5&
Public Const TCM_SETCURFOCUS = &H1330&

Private Const TimeoutSecond = 2

Private g_ProjectName As String
Private g_Password As String
Private g_hwndVBE As Long
Private g_Result As Long
Private g_hwndPassword As Long


Public Function UnlockTimerProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim hwndProjectProp As Long, hwndProjectProp2 As Long
Dim hwndTab As Long, hwndLockProject As Long, hwndPassword As Long
Dim hwndConfirmPassword As Long, hwndOK As Long
Dim hWndTmp As Long, lRet As Long
Dim IDTab As Long, IDLockProject As Long, IDPassword As Long
Dim IDConfirmPassword As Long, IDOK As Long
Dim sCaption As String
Dim timeout As Date, timeout2 As Date
Dim pwd As String

On Error GoTo ErrorHandler
KillTimer 0, idEvent
IDTab = &H3020&
IDLockProject = &H1557&
IDPassword = &H155E&
IDConfirmPassword = &H1556&
IDOK = &H1&
sCaption = " Password"

'for the japanese version
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1041
sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
End Select

sCaption = g_ProjectName & sCaption
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout

hwndPassword = 0
hwndOK = 0

hWndTmp = 0
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
If hWndTmp = 0 Then GoTo Continue
Debug.Print "found window"
lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

hwndPassword = GetDlgItem(hWndTmp, IDPassword)
Debug.Print "hwndpassword: " & hwndPassword

hwndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hwndOK

If (hWndTmp _
And hwndOK) = 0 Then GoTo Continue

lRet = SetFocusAPI(hwndPassword)
lRet = SendMessage(hwndPassword, EM_SETSEL, 0, ByVal -1&)
lRet = SendMessage(hwndPassword, EM_REPLACESEL, 0, ByVal g_Password)

pwd = String(260, Chr(0))
lRet = SendMessage(hwndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
If pwd <> g_Password Then GoTo Continue
lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)

lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

g_Result = 1
Exit Do

Continue:
DoEvents
Sleep 100
Loop
Exit Function

ErrorHandler:
If hwndPassword <> 0 Then SendMessage hwndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function



Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
Dim timeout As Date
Dim lRet As Long

On Error GoTo ErrorHandler
UnlockProject = 1
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If

g_ProjectName = Project.Name
g_Password = Password
' LockWindowUpdate GetDesktopWindow()
Application.VBE.MainWindow.visible = True
g_hwndVBE = Application.VBE.MainWindow.hWnd
g_Result = 0
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then
GoTo ErrorHandler
End If
Application.VBE.CommandBars.FindControl(ID:=2578).Execute

timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then
UnlockProject = 0
End If

AppActivate Application.Caption
LockWindowUpdate 0
Exit Function

ErrorHandler:
AppActivate Application.Caption
LockWindowUpdate 0
End Function

Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "test")
Case 0: MsgBox "The project was unlocked."
Case 2: MsgBox "The active project was already unlocked."
Case Else: MsgBox "Error or timeout."
End Select
End Sub

Function ClosePropertiesWindow(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim timeout As Date
Dim hWndTmp As Long
Dim hwndOK As Long
Dim lRet As Long
Dim sCaption As String


sCaption = g_ProjectName & " - Project Properties"
Debug.Print sCaption

On Error GoTo ErrorHandler
KillTimer 0, idEvent

timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout

hWndTmp = 0
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
If hWndTmp = 0 Then GoTo Continue
Debug.Print "found properties window"
lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

hwndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hwndOK
If (hWndTmp _
And hwndOK) = 0 Then GoTo Continue

lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

g_Result = 1
Exit Do

Continue:
DoEvents
Sleep 100
Loop
Exit Function

ErrorHandler:
Debug.Print Err.number
LockWindowUpdate 0
End Function

[theta]

I am afraid that I do not understand the remainder of your response at all. Could you describe what is happening in better detail?


When you unlock a project, Excel presents a prompt to the user stating the project was unlocked. You have to manualy close / ESC this window. I was hoping the code would capture this window and action the close handle?

[Kenneth Hobs]

Aflatoon's last code will dismiss the unlocked dialog.

I added some missing API's and some constants. I also have a few extra API's but that does not really hurt anything unless you have a lots of other stuff going on that might exceed a stack limit. I tested it in xppro. It should be tested with UAC turned on. I suspect that it will still work ok since it does not use SendKeys().


Option Explicit
' http://www.cpearson.com/excel/vbe.aspx ' other vbe code

' http://www.vbaexpress.com/forum/showthread.php?p=277605 ' unlock project
' http://www.standards.com/Office/SetVBAProjectPassword.html

Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Declare Function GetWindow Lib "user32" ( _
ByVal hwnd As Long, ByVal uCmd As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" ( _
ByVal hwnd As Long) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' Added 3 functions - Kenneth Hobson
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long

' Dialog Box Command IDs
Public Const IDOK = 1
Public Const IDCANCEL = 2
Public Const IDABORT = 3
Public Const IDRETRY = 4
Public Const IDIGNORE = 5
Public Const IDYES = 6
Public Const IDNO = 7

Public Const WM_CLOSE = &H10
Public Const WM_GETTEXT = &HD
Public Const EM_REPLACESEL = &HC2
Public Const EM_SETSEL = &HB1
Public Const BM_CLICK = &HF5&
Public Const TCM_SETCURFOCUS = &H1330&

Private Const TimeoutSecond = 2

Private g_ProjectName As String
Private g_Password As String
Private g_hwndVBE As Long
Private g_Result As Long
Private g_hwndPassword As Long


Public Function UnlockTimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim hwndProjectProp As Long, hwndProjectProp2 As Long
Dim hwndTab As Long, hwndLockProject As Long, hwndPassword As Long
Dim hwndConfirmPassword As Long, hwndOK As Long
Dim hWndTmp As Long, lRet As Long
Dim IDTab As Long, IDLockProject As Long, IDPassword As Long
Dim IDConfirmPassword As Long, IDOK As Long
Dim sCaption As String
Dim timeout As Date, timeout2 As Date
Dim pwd As String

On Error GoTo ErrorHandler
KillTimer 0, idEvent
IDTab = &H3020&
IDLockProject = &H1557&
IDPassword = &H155E&
IDConfirmPassword = &H1556&
IDOK = &H1&
sCaption = " Password"

'for the japanese version
Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI)
Case 1041
sCaption = ChrW(&H30D7) & ChrW(&H30ED) & ChrW(&H30B8) & _
ChrW(&H30A7) & ChrW(&H30AF) & ChrW(&H30C8) & _
ChrW(&H20) & ChrW(&H30D7) & ChrW(&H30ED) & _
ChrW(&H30D1) & ChrW(&H30C6) & ChrW(&H30A3)
End Select

sCaption = g_ProjectName & sCaption
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout

hwndPassword = 0
hwndOK = 0

hWndTmp = 0
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
If hWndTmp = 0 Then GoTo Continue
Debug.Print "found window"
lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

hwndPassword = GetDlgItem(hWndTmp, IDPassword)
Debug.Print "hwndpassword: " & hwndPassword

hwndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hwndOK

If (hWndTmp _
And hwndOK) = 0 Then GoTo Continue

lRet = SetFocusAPI(hwndPassword)
lRet = SendMessage(hwndPassword, EM_SETSEL, 0, ByVal -1&)
lRet = SendMessage(hwndPassword, EM_REPLACESEL, 0, ByVal g_Password)

pwd = String(260, Chr(0))
lRet = SendMessage(hwndPassword, WM_GETTEXT, Len(pwd), ByVal pwd)
pwd = Left(pwd, InStr(1, pwd, Chr(0), 0) - 1)
If pwd <> g_Password Then GoTo Continue
lRet = SetTimer(0, 0, 100, AddressOf ClosePropertiesWindow)

lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

g_Result = 1
Exit Do

Continue:
DoEvents
Sleep 100
Loop
Exit Function

ErrorHandler:
If hwndPassword <> 0 Then SendMessage hwndPassword, WM_CLOSE, 0, ByVal 0&
LockWindowUpdate 0
End Function



Function UnlockProject(ByVal Project As Object, ByVal Password As String) As Long
Dim timeout As Date
Dim lRet As Long

On Error GoTo ErrorHandler
UnlockProject = 1
If Project.Protection <> vbext_pp_locked Then
UnlockProject = 2
Exit Function
End If

g_ProjectName = Project.Name
g_Password = Password
' LockWindowUpdate GetDesktopWindow()
Application.VBE.MainWindow.Visible = True
g_hwndVBE = Application.VBE.MainWindow.hwnd
g_Result = 0
lRet = SetTimer(0, 0, 100, AddressOf UnlockTimerProc)
If lRet = 0 Then
Debug.Print "error setting timer"
GoTo ErrorHandler
End If
Set Application.VBE.ActiveVBProject = Project
If Not Application.VBE.ActiveVBProject Is Project Then
GoTo ErrorHandler
End If
Application.VBE.CommandBars.FindControl(ID:=2578).Execute

timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop
If g_Result Then
UnlockProject = 0
End If

AppActivate Application.Caption
LockWindowUpdate 0
Exit Function

ErrorHandler:
AppActivate Application.Caption
LockWindowUpdate 0
End Function

Sub Test_UnlockProject()
Select Case UnlockProject(ActiveWorkbook.VBProject, "myPassword")
Case 0: MsgBox "The project was unlocked."
Case 2: MsgBox "The active project was already unlocked."
Case Else: MsgBox "Error or timeout."
End Select
End Sub

Function ClosePropertiesWindow(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal idEvent As Long, ByVal dwTime As Long) As Long
Dim timeout As Date
Dim hWndTmp As Long
Dim hwndOK As Long
Dim lRet As Long
Dim sCaption As String


sCaption = g_ProjectName & " - Project Properties"
Debug.Print sCaption

On Error GoTo ErrorHandler
KillTimer 0, idEvent

timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While Now() < timeout

hWndTmp = 0
Do
hWndTmp = FindWindowEx(0, hWndTmp, vbNullString, sCaption)
If hWndTmp = 0 Then Exit Do
Loop Until GetParent(hWndTmp) = g_hwndVBE
If hWndTmp = 0 Then GoTo Continue
Debug.Print "found properties window"
lRet = SendMessage(hWndTmp, TCM_SETCURFOCUS, 1, ByVal 0&)

hwndOK = GetDlgItem(hWndTmp, IDOK)
Debug.Print "hwndOK: " & hwndOK
If (hWndTmp _
And hwndOK) = 0 Then GoTo Continue

lRet = SetFocusAPI(hwndOK)
lRet = SendMessage(hwndOK, BM_CLICK, 0, ByVal 0&)

g_Result = 1
Exit Do

Continue:
DoEvents
Sleep 100
Loop
Exit Function

ErrorHandler:
Debug.Print Err.Number
LockWindowUpdate 0
End Function

[GTO]

Hi All:hi:

I have not gotten to run/study Aflatoon's (at #14) or Kenneth's (at #16) code yet, but hope to get a chance to through the course of the evening. Meanwhile, I am afraid I must be particularly thick-headed today, and not 'getting' a couple of things.


When you unlock a project, Excel presents a prompt to the user stating the project was unlocked. You have to manualy close / ESC this window. I was hoping the code would capture this window and action the close handle?

I do not get a prompt in either 2000 or 2010. Manually, if I double-click or click the plus sign in the Project window, the Password dialog comes up, and upon entering the password and clicking the <OK> button, the project "expands" in the project window. Likewise, if I select the project in the project window, and then go to Tools|Properties from VBE's menubar, I am first prompted for the password, and the then Properties dialog pops up. Is there another dialog that advises that the project was unlocked? If so, should I be looking in options, or is it specific to a version or??? Sorry if I am missing something I should already be seeing.


Aflatoon's last code will dismiss the unlocked dialog.

I added some missing API's and some constants. I also have a few extra API's but that does not really hurt anything unless you have a lots of other stuff going on that might exceed a stack limit. I tested it in xppro. It should be tested with UAC turned on. I suspect that it will still work ok since it does not use SendKeys()...


Hi Kenneth,

Hope all is well in your neck of the woods:)

For whatever reason, I am not catching what UAC is :dunno

Thank you both so much,

Mark

[Kenneth Hobs]

UAC=User Account Control. Microsoft first added it in Vista.

The password to the file is myPassword. Copy my code into the example file's Module to replace it. Close the file and then open. When closed, it resets the project password. Then click the button to unlock the project.

[GTO]

Thank you Ken. XP at home and the PC I am on most at work, but I am certain I saw Windows7 somewheres here at work... As soon as I spot which PC has the later OS, I'll try it out.

Well at least I don't feel quite so clueless, so thanks again :-)

Mark

[theta]

All working. Thanks guys :) I used Ken's code (although I had to modify the following) :



'If Project.Protection <> vbext_pp_locked Then
If Project.Protection <> 1 Then


Very good joint effort - have saved it as an add-in to unlock my projects en-mass.

Many thanks

[Kenneth Hobs]

Why would you need to modify it? The value is one. If you want to see what an object's constant values are, after you set the reference to this object, in the Immediate window type and press Enter key. This is like Debug.Print.

?vbext_pp_locked

[theta]

Trying to reference that object produced an error. But changing it to <>1 fixed the problem.

[GTO]

Hi Theta,

I would bet that we probably all referenced VBIDE when writing/editing the code, and you may not have this library referenced.

Mark

[SamGr]

Aflatoon's last code will dismiss the unlocked dialog.

I added some missing API's and some constants. I also have a few extra API's but that does not really hurt anything unless you have a lots of other stuff going on that might exceed a stack limit. I tested it in xppro. It should be tested with UAC turned on. I suspect that it will still work ok since it does not use SendKeys().


Unfortunately, under Win7 and Excel 2010 doesn' work. The properties window is not closed in my case...
Furthermore, when I try to put the code through a loop in order to unlock various VBA projects (with known passwords) Excel crashes.... I suppose that probably the timer is the cause of my problem but I am not sure... :banghead:

[theta]

Unfortunately, under Win7 and Excel 2010 doesn' work. The properties window is not closed in my case...
Furthermore, when I try to put the code through a loop in order to unlock various VBA projects (with known passwords) Excel crashes.... I suppose that probably the timer is the cause of my problem but I am not sure... :banghead:

I am running windows 7 with office 2010 and it works perfectly....

Do you have all correct references set? Do you have the required DLL's on your machine?

[SamGr]

Sorry, Theta, my mistake... The code from Excel VBA works fine...

I actually have the following problem:
The last few days I decided to organize all my VBA code. I had successfully written some code that loops through (an opened) workbook (that has VBA code) and gets some information about its procedures. Pearson's page helped me a lot.

However, during the weekend I decided to go one step further:
1) I have created a userform in which the user needs to select a folder (with workbooks).
2) After selection, the codes loops through all files in the selected folder and creates a list in a new sheet (with workbooks names, paths etc.).
3) Then the user enters some passwords in a textbox and populates a combobox. This is just to have a visual appearance of what passwords have been entered.
4) Finally, the code loops through all excel files in the following way:
a) Opens the workbook.
b) Unprotects the VB project (if is protected) using the list of passwords of the combo box.
c) Loops through VB project and get info about its procedures.
d) Close the workbook and proceed to the next one.

Having said that, my problem is 4b. Everything else works fine.
I have spent a lot of hours the last 3 days and still I could not achieve this... I exclude of course the sendkeys method...
The code I found here crashes my excel when I am trying to enter a wrong password.

Any ideas?

[SamGr]

I finally manage to finish this.
Since this is only my 3rd post I cannot provide you the link with the application (it is in my blog).
It is not perfect, but at least does what I wanted to do.

Thank you all for your contribution and help! :beerchug:

[sacru2red]

I know its closed thread, comment for other visitors

u may need "Select Case Application.LanguageSettings.LanguageID(msoLanguageIDUI) ..." in "ClosePropertiesWindow" Prosedure
in my cased it didnt work ..

...
and I need to set unlock VBAProject save. ex) uncheck "project Protect" checkbox, remove password String, click OK button.
I am not good at using win32API .. someone solve this, please send email

[Paul_Hossler]

If you're asking to bypass the password, you won't get help here - best try to get the password from the Creator.


http://www.vbaexpress.com/forum/faq.php?faq=psting_faq_item#faq_hack_faq_item (http://www.vbaexpress.com/forum/faq.php?faq=psting_faq_item#faq_hack_faq_item)



Can I ask hacking / cracking questions here?

Requests for help or answers aiding in the pirating of intellectual property or involving hacking/cracking of password protection of document files or software programs is strictly prohibited on the site. We are all professionals here and, as a community, it is our decision to respect the intellectual and potentially confidential property of others.



Please do not ask anyone to help with lost CD keys; you must contact the software supplier for this information.


If you have the password, and want to use Sendkeys (which I don't think will work), it'd be better to start a new thread instead of tagging onto an 8 year old one

[sacru2red]

hi Paul_Hossler,

I dont asking "hacking Tech". I have many .xlsm Files made by me. I am just manage my Files.
Like to add moduleFiles etc..

[Paul_Hossler]

The last time I checked, the ability to unlock a file required manually entering the PW for security reasons

I don't think you can use SendKeys

[poielsd]

You'd better unlock them manually.

[poielsd]

You'd better unlock them manually.