Project locked for viewing - SendKeys?

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 ...

You'd better unlock them manually.

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?

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

[vba]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[/vba]

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

Code:

---

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

---

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 :)

Code:

---

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

---

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

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

Quote:

---

Originally Posted by 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) ?

Code:

---

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

---

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!

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. :)

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/SetV...tPassword.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

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...

Quote:

---

Originally Posted by 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...

---

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

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!

Code:

---

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

---

Quote:

---

Originally Posted by GTO

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?

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().

Code:

---

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/SetV...tPassword.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

---

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.

Quote:

---

Originally Posted by theta

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.

Quote:

---

Originally Posted by 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()...

---

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

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.

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

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

Code:

---

    '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

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.

Code:

---

?vbext_pp_locked

---

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

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

Quote:

---

Originally Posted by 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().

---

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:

Quote:

---

Originally Posted by SamGr

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?

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?

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:

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

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

Quote:

---

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

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..

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

You'd better unlock them manually.

You'd better unlock them manually.