Prevent VBE from idling when user action is required (Win32 APIs)

H

hymced

New Member
Joined
Sep 25, 2017
Messages
42
Hi all, Hi Jaafar ;)

I am working on a tool manipulating the VBProject of other Excel files, which can have their VBProject locked with 2 different passwords. But I have no way to know which one it will be in advanced, so I must attempt them one after the other. I managed to write some code that runs in a main Excel.Application instance so that I can work on the VBE windows of the other Excel.Application instance (containing the locked project) to input a password. I sucessfully unlocked some projects this way (I found this solution more elegant and 100% working compared to the SendKeys method that gives random results and would not work in my particular case)

One can verify I do end up with 2 different Excel processes, because I have 2 VBE Window in my Windows Task Bar:

INSTANCES

But when the password is incorrect, a "Project Locked / Invalid password" dialog appears, and it happens to even stop execution in my main running instance using the Win32 APIs. I think it must somehow throw an exception to my main running instance, which requires that the user clicks the "OK" button in the dialog for the execution to continue.

ERROR

I would like to by-pass this interaction with the user to have something fully automated.

I came with a solution that I have not yet fully carried through: generate a worker file that I would run in a third Excel.Application instance just before confirming the password in the previous dialog, which would detect the "Project Locked / Invalid password" dialog and close it, so the execution can continue in my main running instance, allowing me to try the second password. This workaround seems very heavy and unnatural...

Another quick workaround is to use the Sendkeys method of the locked project's Application to send an {ESC} key just before confirming the password. This works to close the error dialog, giving back control to the main VBE. But the whole point of my tool is to avoid using SendKeys...

Would there be another way? One that would prevent the VBE from idling in my main running instance (making the dialog modeless, etc. I really don't know...)

Here is the code to illustrate my problem. This is not exactly simple, but as minimal as it gets. I think it is meaningless for anybody capable of understanding the problem with major principles, and able of giving me hints to workaround this issue...

NOTE: look for my 3 comments in CAPITAL LETTERS

VBA Code: 
#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As 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 GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
   
    Dim Ret As LongPtr, ChildRet As LongPtr, OpenRet As LongPtr
#Else
    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 Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
    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
   
    Dim Ret As Long, ChildRet As Long, OpenRet As Long
#End If

Dim strBuff As String, ButCap As String

Const WM_SETTEXT = &HC
Const BM_CLICK = &HF5

Const WORKAROUND1_SENDKEYS_ESC = True

Sub Main()
    Call UnlockVBA("password1")
End Sub

Sub UnlockVBA(ByVal pwd As String)
   
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = -1
    Set Wb = xlApp.Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "DUMMY_LOCKED_VBPROJECT.xlsm", UpdateLinks:=False)
    Set vbProj = Wb.VBProject
    Set xlApp.VBE.ActiveVBProject = vbProj
   
    DoEvents
   
    xlApp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
   
    DoEvents
   
    Ret = FindWindow(vbNullString, vbProj.Name & " Password")
   
    If Ret <> 0 Then
       
        '~~> Get the handle of the TextBox Window where we need to type the password
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)
       
        If ChildRet <> 0 Then
            '~~> Type the password in the TextBox Window
            SendMess pwd, ChildRet
            DoEvents
           
            '~~> Search for the "OK" Button among siblings of the TextBox Child Window
            '~~> Get the handle of the first Child Window of class "Button"
            ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
            If ChildRet <> 0 Then
                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff
                '~~> Loop through all child windows
                Do While ChildRet <> 0
                    '~~> Check if the caption has the word "OK"
                    If InStr(1, ButCap, "OK") Then
                        '~~> If this is the button we are looking for then exit
                        OKRet = ChildRet
                        Exit Do
                    End If
                    '~~> Get the handle of the next child window
                    ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                    '~~> Get the caption of the child window
                    strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                    GetWindowText ChildRet, strBuff, Len(strBuff)
                    ButCap = strBuff
                Loop
                '~~> Check if we found it or not
                If OKRet <> 0 Then
                    '~~> Click the OK Button
                   
                    If Not WORKAROUND1_SENDKEYS_ESC Then
                        MsgBox "before user click"
                    ElseIf WORKAROUND1_SENDKEYS_ESC Then
                        xlApp.SendKeys "{ESC}"
                    End If
                    SendMessage OKRet, BM_CLICK, 0, vbNullString
                    ' >>> IF INCORRECT PASSWORD, MAIN VBE IDLES HERE UNTIL USER CANCELS THE ERROR IN THE OTHER VBE <<<
                   
                    MsgBox "after user click"
                    ' >>> AT THIS POINT, THE ERROR DIALOG HAS BEEN DISMISSED BY THE USER, I WAS NOT EXPECTING THIS INTERACTION, NEITHER THAT THE ERROR DIALOG WOULD IDLE THE MAIN VBE, SO THE FOLLOWING CODE DOES NOT WORK PROPERLY

                    '~~> Check if password has worked and VBProject Properties Window is displayed
                    Ret = FindWindow(vbNullString, vbProj.Name & " - Project Properties")
                    If Ret <> 0 Then
                        '~~> Get the handle of the first Child Window of class "Button"
                        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
                        '~~> Check if we found it or not
                        If ChildRet <> 0 Then
                            '~~> Get the caption of the child window
                            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                            GetWindowText ChildRet, strBuff, Len(strBuff)
                            ButCap = strBuff
                            '~~> Loop through all next child windows
                            Do While ChildRet <> 0
                                '~~> Check if the caption has the word "OK"
                                If InStr(1, ButCap, "OK") Then
                                    '~~> If this is the button we are looking for then exit
                                    OK2Ret = ChildRet
                                    Exit Do
                                End If
                                '~~> Get the handle of the next child window
                                ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                                '~~> Get the caption of the child window
                                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                                GetWindowText ChildRet, strBuff, Len(strBuff)
                                ButCap = strBuff
                            Loop
                            '~~> Check if we found it or not
                            If OK2Ret <> 0 Then
               
                                '~~> Click the OK again Button to close VBProject Properties
                                SendMessage OK2Ret, BM_CLICK, 0, vbNullString
                                DoEvents
                               
                                '~~> AT THIS POINT, the VBProject should be unlocked
                           
                            End If
                        End If
                    Else
                       
                        '~~> "Project Locked / Invalid password" Window might be displayed
                       
                        ' #32769 (Desktop Window) "EXCEL.EXE"
                        '   #32770 (Dialog) "Project Locked" (top-level window owned by the top-level dialog window "VBAProject Password", itself owned by the top-level window of class wndclass_desked_gsk "VBE")
                        '       Button "OK"
                        '       Static ""
                        '       Static "Invalid password"
                       
                        'Project Locked
                        '/!\ Invalid password
                       
                        Ret = FindWindow(vbNullString, "Project Locked")
                       
                        If Ret <> 0 Then
                            ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
                            If ChildRet <> 0 Then
                                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                                GetWindowText ChildRet, strBuff, Len(strBuff)
                                ButCap = strBuff
                                Do While ChildRet <> 0
                                    If InStr(1, ButCap, "OK") Then
                                        OK3Ret = ChildRet
                                        Exit Do
                                    End If
                                    ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                                    strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                                    GetWindowText ChildRet, strBuff, Len(strBuff)
                                    ButCap = strBuff
                                Loop
                                If OK3Ret <> 0 Then
                                    SendMessage OK3Ret, BM_CLICK, 0, vbNullString
                                    DoEvents
                                   
                                    '~~> Close VBAProject Password Window
                                   
                                    ' #32769 (Desktop Window) "EXCEL.EXE"
                                    '   #32770 (Dialog) "vbProj.Name Password"
                                    '       Button "OK"
                                    '       Button "Cancel"
                                    '       Static "&Password"
                                    '       Edit ""
                                   
                                    Ret = FindWindow(vbNullString, vbProj.Name & " Password")
                                    If Ret <> 0 Then
                                        ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)
                                        If ChildRet <> 0 Then
                                            strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                                            GetWindowText ChildRet, strBuff, Len(strBuff)
                                            ButCap = strBuff
                                            Do While ChildRet <> 0
                                                If InStr(1, ButCap, "Cancel") Then
                                                    CancelRet = ChildRet
                                                    Exit Do
                                                End If
                                                ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                                                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                                                GetWindowText ChildRet, strBuff, Len(strBuff)
                                                ButCap = strBuff
                                            Loop
                                            If CancelRet <> 0 Then
                                                SendMessage CancelRet, BM_CLICK, 0, vbNullString
                                                DoEvents
                                               
                                                '~~> Check if VBProject Properties is NOT displayed
                                                Ret = FindWindow(vbNullString, vbProj.Name & " - Project Properties")
                                                If Ret = 0 Then
                                                    '~~> ok! ready to try to call the sub with another password
                                                Else
                                                    '~~> hum...
                                                End If
                                            End If
                                        End If
                                    End If
                                End If
                            End If
                        End If ' >>> SUB GOES OUT HERE, THE TEXT BOX DIALOG IN THE OTHER VBE IS STILL VISIBLE
                    End If
                End If
            End If
        End If
    End If
End Sub

#If VBA7 Then
    Sub SendMess(Message As String, hWnd As LongPtr)
        Call SendMessage(hWnd, WM_SETTEXT, False, ByVal Message)
    End Sub
#Else
    Sub SendMess(Message As String, hWnd As Long)
        Call SendMessage(hWnd, WM_SETTEXT, False, ByVal Message)
    End Sub
#End If
 

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
Sort by date Sort by votes
A reminder:

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: VBA Code to Close Excel Automatically if in Idle Mode (Win32 APIs)
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.
 
Upvote 0
Somone suggested me WinEvents / UI Automation to solve this, but I have no idea how to translate the C++ example I can find in VBA, or even if it is possible or if it will prevent my main instance from freezing
 
Upvote 0
This workaround worked for me hymced,

No SendKeys used and no need to use a second instance of excel.


1- In a Standard Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) 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 LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
  
    Private lHook As LongPtr
#Else
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function SetWindowPos Lib "user32" (ByVal Hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags 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 PostMessage Lib "user32" Alias "PostMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  
    Private lHook As Long
#End If

Private oWb As Workbook, sPassword As String



Public Function UnLockVBAProject(ByVal Wb As Workbook, ByVal Password As String) As Boolean

    Const WH_CBT = 5
  
    With Wb.Application.VBE
        Set .ActiveVBProject = Wb.VBProject
        If .ActiveVBProject.Protection = 0 Then
            MsgBox "VBProject already unlocked": Exit Function
        End If
        If .ActiveVBProject.Protection Then
            Set oWb = Wb
            TopMost(Application.hwnd) = True
            sPassword = Password
            lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Activation, 0, GetCurrentThreadId)
            Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
            DoEvents
            TopMost(FindWindow("wndclass_desked_gsk", vbNullString)) = False
            If Wb.VBProject.Protection = 0 Then
                UnLockVBAProject = True
            End If
        End If
    End With
  
    Exit Function

errHandler:
    Call UnHook
    TopMost(Application.hwnd) = False
    MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation

End Function

#If Win64 Then
    Private Function Catch_DlgBox_Activation(ByVal idHook As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function Catch_DlgBox_Activation(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const HCBT_ACTIVATE = 5
    Const SWP_HIDEWINDOW = &H80
    Dim sbuff As String * 256, lRet As Long

    TopMost(FindWindow("wndclass_desked_gsk", vbNullString)) = False
  
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sbuff, 256)
        If Left(sbuff, lRet) = "#32770" Then
            sbuff = ""
            lRet = GetWindowText(wParam, sbuff, 256)
            If Left(sbuff, lRet) = "VBAProject Password" Then
                Call UnHook
                Call SetTimer(Application.hwnd, wParam, 0, AddressOf UnProtectProc)
            End If
        End If
    End If
  
    Catch_DlgBox_Activation = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

#If Win64 Then
Private Sub UnProtectProc(ByVal hwnd As LongLong, ByVal uMsg As Long, ByVal nIDEvent As LongLong, ByVal dwTimer As Long)
    Dim hCurrentDlg As LongLong
#Else
Private Sub UnProtectProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim hCurrentDlg As Long
#End If

    Const EM_SETMODIFY = &HB9
    Const BM_CLICK = &HF5
    Const WM_SETTEXT = &HC

    On Error GoTo errHandler
  
    Call KillTimer(Application.hwnd, nIDEvent)
    hCurrentDlg = nIDEvent
    Call SetTimer(Application.hwnd, 0, 0, AddressOf CloseDialogs)
    Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), WM_SETTEXT, 0, sPassword)
    Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), EM_SETMODIFY, True, 0)
    Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
    sPassword = vbNullString
    Exit Sub
  
errHandler:
    Call KillTimer(Application.hwnd, 0)
    MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation

End Sub

Private Sub CloseDialogs()

    Const BM_CLICK = &HF5
    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
  
    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Call KillTimer(Application.hwnd, 0)
    hwnd = FindWindow(vbNullString, "Project Locked")

    If hwnd Then
       Call SendMessage(GetDlgItem(hwnd, &H2), BM_CLICK, 0, 0)
    End If

    If GetActiveWindow <> Application.hwnd Then
        Call PostMessage(FindWindow(vbNullString, "VBAProject Password"), WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
        Call PostMessage(FindWindow(vbNullString, "VBAProject - Project Properties"), WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
    End If

    TopMost(Application.hwnd) = False

End Sub

#If Win64 Then
    Private Property Let TopMost(ByVal hwnd As LongLong, ByVal bTopMost As Boolean)
#Else
    Private Property Let TopMost(ByVal hwnd As Long, ByVal bTopMost As Boolean)
#End If

    Const SWP_NOSIZE = &H1
    Const SWP_NOMOVE = &H2
    Const SWP_SHOWWINDOW = &H40
    Const HWND_TOPMOST = -1
    Const HWND_NOTOPMOST = -2

    Call SetWindowPos(hwnd, IIf(bTopMost = True, HWND_TOPMOST, HWND_NOTOPMOST), _
            0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_SHOWWINDOW)

End Property

Private Sub UnHook()
    UnhookWindowsHookEx lHook
End Sub



2- Code Usage Example:
Change the name of the test workbook as needed.

VBA Code: 
Option Explicit

Sub UnLock_Example()

    'Try with first Password.
    If UnLockVBAProject(Workbooks("MyTestBook.xls"), Password:="Wrong Password") = False Then
        'If first password was wrong, try with second Password.
        If UnLockVBAProject(Workbooks("MyTestBook.xls"), Password:="1234") = True Then   '<== 1234 is the correct password.
            MsgBox "VBAProject successfully unprotected."
        Else
            If Workbooks("MyTestBook.xls").VBProject.Protection = 1 Then
                MsgBox "Failed to unprotect VBAProject."
            End If
        End If
    End If

End Sub

I hope it works for you as well.
 
Upvote 0
Throughout the above code, I have used a routine to toggle the topmost windows in order to reduce screen flickering but after a couple of more tests, this toggling is causing some random screen freezing- So, I have decided to remove this routine ... Also, the public oWB variable shouldn't be there.

So please, ignore the previous code and use the following one:

1- Standard Module:
VBA Code: 
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As LongPtr) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal ncode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As String) 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 LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
 
    Private lHook As LongPtr
#Else
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hhk As Long) As Long
    Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal Hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal Hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal Hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 
    Private lHook As Long
#End If

Private sPassword As String


Public Function UnLockVBAProject(ByVal Wb As Workbook, ByVal Password As String) As Boolean

    Const WH_CBT = 5
 
    With Wb.Application.VBE
        Set .ActiveVBProject = Wb.VBProject
        If .ActiveVBProject.Protection = 0 Then
            MsgBox "VBProject already unlocked": Exit Function
        End If
        If .ActiveVBProject.Protection Then
            sPassword = Password
            lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Activation, 0, GetCurrentThreadId)
            Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
            DoEvents
            If Wb.VBProject.Protection = 0 Then
                UnLockVBAProject = True
            End If
        End If
    End With
 
    Exit Function

errHandler:
    Call UnHook
    MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation

End Function

#If Win64 Then
    Private Function Catch_DlgBox_Activation(ByVal idHook As Long, ByVal wParam As LongLong, ByVal lParam As LongLong) As LongLong
#Else
    Private Function Catch_DlgBox_Activation(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const HCBT_ACTIVATE = 5
    Const SWP_HIDEWINDOW = &H80
    Dim sbuff As String * 256, lRet As Long
 
    If idHook = HCBT_ACTIVATE Then
        lRet = GetClassName(wParam, sbuff, 256)
        If Left(sbuff, lRet) = "#32770" Then
            sbuff = ""
            lRet = GetWindowText(wParam, sbuff, 256)
            If Left(sbuff, lRet) = "VBAProject Password" Then
                Call UnHook
                Call SetTimer(Application.hwnd, wParam, 0, AddressOf UnProtectProc)
            End If
        End If
    End If
 
    Catch_DlgBox_Activation = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
 
End Function

#If Win64 Then
Private Sub UnProtectProc(ByVal hwnd As LongLong, ByVal uMsg As Long, ByVal nIDEvent As LongLong, ByVal dwTimer As Long)
    Dim hCurrentDlg As LongLong
#Else
Private Sub UnProtectProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim hCurrentDlg As Long
#End If

    Const EM_SETMODIFY = &HB9
    Const BM_CLICK = &HF5
    Const WM_SETTEXT = &HC

    On Error GoTo errHandler
 
    Call KillTimer(Application.hwnd, nIDEvent)
    hCurrentDlg = nIDEvent
    Call SetTimer(Application.hwnd, 0, 0, AddressOf CloseDialogs)
    Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), WM_SETTEXT, 0, sPassword)
    Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), EM_SETMODIFY, True, 0)
    Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
    sPassword = vbNullString
    Exit Sub
 
errHandler:
    Call KillTimer(Application.hwnd, 0)
    MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation

End Sub

Private Sub CloseDialogs()

    Const BM_CLICK = &HF5
    Const WM_SYSCOMMAND = &H112
    Const SC_CLOSE = &HF060&
 
    #If Win64 Then
        Dim hwnd As LongLong
    #Else
        Dim hwnd As Long
    #End If

    Call KillTimer(Application.hwnd, 0)
    hwnd = FindWindow(vbNullString, "Project Locked")

    If hwnd Then
       Call SendMessage(GetDlgItem(hwnd, &H2), BM_CLICK, 0, 0)
    End If

    If GetActiveWindow <> Application.hwnd Then
        Call PostMessage(FindWindow(vbNullString, "VBAProject Password"), WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
        Call PostMessage(FindWindow(vbNullString, "VBAProject - Project Properties"), WM_SYSCOMMAND, SC_CLOSE, ByVal 0)
    End If

End Sub

Private Sub UnHook()
    UnhookWindowsHookEx lHook
End Sub



2- Code Usage Example:
VBA Code: 
Option Explicit

Sub UnLock_Example()
   
    'Try with first Password.
    If UnLockVBAProject(Workbooks("MyTestBook.xls"), Password:="Wrong Password") = False Then
        'If first password was wrong, try with second Password.
        If UnLockVBAProject(Workbooks("MyTestBook.xls"), Password:="1234") = True Then   '<== 1234 is the correct password.
            MsgBox "VBAProject successfully unprotected."
        Else
            If Workbooks("MyTestBook.xls").VBProject.Protection = 1 Then
                MsgBox "Failed to unprotect VBAProject."
            End If
        End If
    Else
        MsgBox "VBAProject successfully unprotected."
    End If
   
End Sub
 
Upvote 0
Neat. Subclassing of course ! For the flickering of the dialogs my solution was to lock the Workbook Window as the topmost with SetWindowPos.

I'll give it a try to see if it stable, which might not always be the case with subclassing from VBA...

Thanks
 
Upvote 0
hymced said:
Neat. Subclassing of course ! For the flickering of the dialogs my solution was to lock the Workbook Window as the topmost with SetWindowPos.

I'll give it a try to see if it stable, which might not always be the case with subclassing from VBA...

Thanks
Click to expand...
The code doesn't use any subclassing... It does however install a WH_CBT hook and and runs a couple of win32 timers.

Installing\UnInstalling a windows hook correctly and when appropriate can actually be quite stable in vba.
 
Upvote 0
I managed to do something similar with WinEvents, to detect window creation (tested only in the same process for now)

But it works only if I schedule the procedure with a non-zero delay

If I schedule calls without a minimum delay, the WinEventProc keeps receiving EVENT_OBJECT_CREATE event messages associated with the "EXCEL7" window (the sheet portion with the cells) indefinitely. This occurs with the DEMO 1 and DEMO 3 parts in my code below, but not with DEMO 2 and DEMO 4. Once the flow of event messages has started, I can't even call the unhook function, the VBE is always busy, so I need to force quit the EXCEL.EXE process...

Would you know why? I am just trying to grasp the concepts at work here. A 10 ms delay to workaround this is fine by me otherwise.

VBA Code: 
Option Explicit

'--------------------------------------
'--------------------------------------
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long

Dim strBuff As String, WndCap As String

Public i As Long
'--------------------------------------
'--------------------------------------

Private Const WINEVENT_OUTOFCONTEXT = 0

Private Const EVENT_OBJECT_CREATE = &H8000&

Private Declare Function SetWinEventHook Lib "user32.dll" (ByVal eventMin As Long, ByVal eventMax As Long, _
    ByVal hmodWinEventProc As Long, ByVal pfnWinEventProc As Long, ByVal idProcess As Long, _
    ByVal idThread As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Private Declare Function UnhookWinEvent Lib "user32.dll" ( _
      ByVal hWinEventHook As Long) As Long

Private pRunningHandles As Collection

Public Function StartEventHook() As Long
  If pRunningHandles Is Nothing Then Set pRunningHandles = New Collection
  'StartEventHook = SetWinEventHook(EVENT_SYSTEM_FOREGROUND, EVENT_SYSTEM_FOREGROUND, 0&, AddressOf WinEventProc, 0, 0, WINEVENT_OUTOFCONTEXT)
  StartEventHook = SetWinEventHook(EVENT_OBJECT_CREATE, EVENT_OBJECT_CREATE, 0&, AddressOf WinEventProc, 0&, 0&, WINEVENT_OUTOFCONTEXT)
  pRunningHandles.Add StartEventHook
End Function

Public Sub StopEventHook(lHook As Long)
  Dim LRet As Long
  If lHook = 0 Then Exit Sub
 
  LRet = UnhookWinEvent(lHook)
 
End Sub

Public Sub StartHook()
    i = 1
    StartEventHook
End Sub

Public Sub StopAllEventHooks()
  Dim vHook As Variant, lHook As Long
  For Each vHook In pRunningHandles
    lHook = vHook
    StopEventHook lHook
  Next vHook
End Sub

Public Sub WinEventProc(ByVal HookHandle As Long, ByVal LEvent As Long, _
                            ByVal hwnd As Long, ByVal idObject As Long, ByVal idChild As Long, _
                            ByVal idEventThread As Long, ByVal dwmsEventTime As Long)
  'This function is a callback passed to the win32 api
  'We CANNOT throw an error or break. Bad things will happen.
  On Error Resume Next
  Dim thePID As Long
 
  If LEvent = EVENT_OBJECT_CREATE Then
    GetWindowThreadProcessId hwnd, thePID
    If thePID = GetCurrentProcessId Then
     
        'MANUAL COMPILE SEEMS REQUIRED IF CHANGES ARE MADE BELOW, OTHERWISE EXCEL MAY CRASH
     
        strBuff = String(GetWindowTextLength(hwnd) + 1, Chr$(0))
        GetWindowText hwnd, strBuff, Len(strBuff)
        WndCap = strBuff
        WndCap = Left(WndCap, Len(WndCap) - 1) 'removing the trailing null char otherwise the Application.OnTime procedure string is cut
     
        i = i + 1
     
    
        'DEMO 1
        Application.OnTime Now, "EVENT_OBJECT_CREATE_1"

        'DEMO 2
        Application.OnTime Now + TimeSerial(0, 0, 1), "EVENT_OBJECT_CREATE_1"
     
        'DEMO 3
        Application.OnTime Now, "'EVENT_OBJECT_CREATE_3 """ & CStr(thePID) & """,""" & CStr(hwnd) & """,""" & WndCap & """'"
     
        'DEMO 4
        If WndCap Like "*Projet verrouillé*" Then
            Application.OnTime Now, "'EVENT_OBJECT_CREATE_3 """ & CStr(thePID) & """,""" & CStr(hwnd) & """,""" & WndCap & """'"
        End If
     
    End If
  End If
 
  On Error GoTo 0
End Sub

Public Sub EVENT_OBJECT_CREATE_1()
  
    DoEvents 'Excel crashes without DoEvents because to many event messages are received
  
    Feuil1.Cells(i, 2).Value = "EVENT_OBJECT_CREATE"
End Sub

Public Sub EVENT_OBJECT_CREATE_2(PID As Long, hwnd As Long, WndCap As String)
  
    DoEvents 'Excel crashes without DoEvents because to many event messages are received
  
    Debug.Print i, "EVENT_OBJECT_CREATE", PID, Hex(hwnd), WndCap
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Run a macro in a workbook using a separate instance of Excel
Replies
0
Views
986
StillUnderstanding
S
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
293
huiettcm
H
A
  • Question
What is wrong with this VBA code: userForm get hand ico for pointer on hover
2
Replies
15
Views
507
RoryA
RoryA
N
  • Question
Getting Compile error: Use on 64-Bit systems ... PtrSafe Attribute for Form Minimize and Maximize
Replies
6
Views
924
NimishK
N
C
  • Solved
Trying to find the name of a child via AccessibleChildren Lib "oleacc"
Replies
2
Views
895
Jaafar Tribak
Jaafar Tribak

Forum statistics

Threads
1,214,784
Messages
6,121,536
Members
449,037
Latest member
tmmotairi

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top