Lock-UnLock VBAProjects Programmatically without SendKeys

[Jaafar Tribak]

Hi all,

I Have recently written this piece of code so I just thought I would post it here for future reference should anyone be looking for vba code to lock\unlock a vbaproject programmatically without needing to use the unreliable SendKeys method.

workbook example

This code requires that the excel macro security setting "Trust access to the vba project object model" be checked... .Also, it is worth mentioning that this code is language-specific as it reads the VBE dialog captions. So this code won't work in Non-English editions of excel but, should be easy to adapt with some small changes.

The code was written and tested in excel 2016-64bit.

Code goes in a Standard Module:

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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) 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 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 SetFocus Lib "user32" (ByVal hwnd As LongPtr) 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 SetActiveWindow Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    
    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 GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag 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 SetFocus Lib "user32" (ByVal hwnd As Long) 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 SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long
    
    Private lHook As Long
#End If

Private sWinClassName As String, sWorkbookName As String, sPassword As String



Public Property Let LockVBProject(ByVal WorkbookName As String, ByVal Password As String, ByVal bLock As Boolean)

    #If VBA7 Then
        Dim hwnd As LongPtr
    #Else
        Dim hwnd As Long
    #End If
    
    Const WH_CBT = 5

    On Error GoTo errHandler

    hwnd = GetActiveWindow
    
    With Application.VBE
        Set .ActiveVBProject = Application.Workbooks(WorkbookName).VBProject
        If bLock Then
            If .ActiveVBProject.Protection = 0 Then
                sWinClassName = "VBAProject - Project Properties"
                sWorkbookName = WorkbookName
            Else
                MsgBox "VBProect already locked": Exit Property
            End If
        Else
            If .ActiveVBProject.Protection Then
                sWinClassName = "VBAProject Password"
            Else
                MsgBox "VBProect already unlocked": Exit Property
            End If
        End If
    End With
    
    sPassword = Password
    lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Activation, 0, GetCurrentThreadId)
    Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute
    
    If hwnd = Application.hwnd Then
        SetActiveWindow Application.hwnd
    End If
    
Exit Property

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



#If VBA7 Then
    Private Function Catch_DlgBox_Activation(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
        Dim hwnd As LongPtr
#Else
    Private Function Catch_DlgBox_Activation(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
        Dim hwnd 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) = sWinClassName Then
            Call UnHook
            SetWindowPos wParam, 0, 0, 0, 0, 0, SWP_HIDEWINDOW
            Call SetTimer(Application.hwnd, wParam, 0, AddressOf Protect_UnProtect_Routine)
        End If
    End If
    End If
    
    Catch_DlgBox_Activation = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)
 
End Function


Private Sub UnHook()
    UnhookWindowsHookEx lHook
End Sub


#If VBA7 Then
Private Sub Protect_UnProtect_Routine(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
    Dim hCurrentDlg As LongPtr, hwndSysTab As LongPtr
#Else
Private Sub Protect_UnProtect_Routine(ByVal hwnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
    Dim hCurrentDlg As Long, hwndSysTab As Long
#End If

    Const TCM_FIRST = &H1300
    Const TCM_SETCURSEL = (TCM_FIRST + 12)
    Const TCM_SETCURFOCUS = (TCM_FIRST + 48)
    Const EM_SETMODIFY = &HB9
    Const BM_SETCHECK = &HF1
    Const BST_CHECKED = &H1
    Const BM_GETCHECK = &HF0
    Const BM_CLICK = &HF5
    Const WM_SETTEXT = &HC
    Const WH_CBT = 5
    Const GW_CHILD = 5
    
    On Error GoTo errHandler
    
    Call KillTimer(Application.hwnd, nIDEvent)
    
    hCurrentDlg = nIDEvent
    
    If sWinClassName = "VBAProject - Project Properties" Then
    
        hwndSysTab = FindWindowEx(hCurrentDlg, 0, "SysTabControl32", vbNullString)
        Call SendMessage(hwndSysTab, TCM_SETCURFOCUS, 1, 0)
        Call SendMessage(hwndSysTab, TCM_SETCURSEL, 1, 0)
        
        If SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_GETCHECK, 0, 0) = 0 Then
            Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_SETCHECK, BST_CHECKED, 0)
            Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), WM_SETTEXT, 0, sPassword)
            Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), EM_SETMODIFY, True, 0)
            Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), WM_SETTEXT, 0, sPassword)
            Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), EM_SETMODIFY, True, 0)
        End If
        
        Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
        Call Application.OnTime(Now, "SaveVBProjectChanges")
        
    ElseIf sWinClassName = "VBAProject Password" Then
    
        Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), WM_SETTEXT, 0, sPassword)
        Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), EM_SETMODIFY, True, 0)
        lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Creation, 0, GetCurrentThreadId)
        Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
        Call Application.OnTime(Now, "UnHook")
        
    End If
    
    Exit Sub
    
errHandler:
    Call UnHook
    MsgBox "Runtime Error : " & Err.Number & vbCr & vbCr & Err.Description, vbExclamation


End Sub


#If VBA7 Then
    Private Function Catch_DlgBox_Creation(ByVal idHook As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Private Function Catch_DlgBox_Creation(ByVal idHook As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If

    Const HCBT_CREATEWND = 3
    Dim sBuff As String * 256, lRet As Long
    
    If idHook = HCBT_CREATEWND Then
        lRet = GetClassName(wParam, sBuff, 256)
        If Left(sBuff, lRet) = "#32770" Then
            Catch_DlgBox_Creation = -1
            Exit Function
        End If
    End If
    
    Catch_DlgBox_Creation = CallNextHookEx(lHook, idHook, ByVal wParam, ByVal lParam)

End Function

Private Sub SaveVBProjectChanges()
    On Error Resume Next
    Application.EnableEvents = False
        Workbooks(sWorkbookName).Save
    Application.EnableEvents = True
End Sub

Code usage examples :

Sub Lock_Example()

    'To lock the vbproject. (change workbook name as required)
        LockVBProject(WorkbookName:="MyTestBook.xls", Password:="1234") = True

End Sub

Sub UnLock_Example()

    'To un-lock the vbproject. (change workbook name as required)
        LockVBProject(WorkbookName:="MyTestBook.xls", Password:="1234") = False

End Sub

 

[gebarbour]

Hi Jaafar,
The code worked perfectly for one time and then, when run again, it does not read the password in LockVBProject(WorkbookName:="MyTestBook.xls", Password:="1234") = False
but rather, it brings up the regular Enter Password form, then, Excel crashes if trying to close the workbook! I tried to restart my computer in case there is a memory conflict, however, this did not resolve the issue. Any precautions I should take care of!
Thanks in advance for the advice.

Hi Zak
I have the exact same problem. Did you work out a solution?

 

[Jaafar Tribak]

Hi Zak
I have the exact same problem. Did you work out a solution?

I am afraid, I couldn't reproduce the problem you are describing. Not sure why this is happening.

 

[gebarbour]

Hi Jaafar, I worked out it was because I had a different project name and it changes the window caption. The code is great so thank you. I did have one other problem where the unlock was happening too slowly for the code I was running afterwards so I put some code in to wait for the result (I found this on stackflow..sadly I cannot re-find the post to give credit).

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

dim timeoutsecond as long: timeoutsecond = 2
' Loop until callback procedure 'UnlockTimerProc' has run
' determine run by watching the state of the global variable 'g_result'
' ... or backstop of 2 seconds max
timeout = Now() + TimeSerial(0, 0, TimeoutSecond)
Do While g_Result = 0 And Now() < timeout
DoEvents
Loop

 

[ABNOTECHGuy]

This is brilliant! Thank you for sharing this code. Works a treat.

What changes would be required to make this code work in other Office apps (Word, PowerPoint, Publisher, Visio etc)?
I tried using it in PowerPoint and it errors here:

 

[Jaafar Tribak]

@ABNOTECHGuy

I am not familar with the PPT object model but it seems that it lacks the HWND Property.

Try retrieving the hwnd of the PPT application via code as follows:

Place the following in a new Standard Module :

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

#If Win64 Then
    Function PPTHwnd() As LongLong
#Else
    Function PPTHwnd() As Long
#End If
    PPTHwnd = FindWindow("PPTFrameClass", vbNullString)
End Function

Now, just replace each instance of Application.Hnwd located in the code with PPTHwnd

 

[ABNOTECHGuy]

@ABNOTECHGuy

I am not familar with the PPT object model but it seems that it lacks the HWND Property.

Try retrieving the hwnd of the PPT application via code as follows:

Place the following in a new Standard Module :

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
#Else
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If

#If Win64 Then
    Function PPTHwnd() As LongLong
#Else
    Function PPTHwnd() As Long
#End If
    PPTHwnd = FindWindow("PPTFrameClass", vbNullString)
End Function

Now, just replace each instance of Application.Hnwd located in the code with PPTHwnd

Tried your suggestion and added a second module. Unfortunately, the App crashes.
Secondly, I tried adding the code to the original module, only I added the declare lines to the Option Explicit from the original code:

... and then put the PPTHwnd functions just below that, however, when executed it crashes the application on this line:

 

[Jaafar Tribak]

Hi ABNOTECHGuy

The error in that line probably suggests the vbe control is not recognized in PPT which I find strange because I believe the VBE is identical accross all Office applications.

I am afraid, I don"t have PPT at hand at the moment. I will take a look at this again when ready.

 

[ABNOTECHGuy]

@Jaafar Tribak
I've worked out the issue with PowerPoint.

1. In the "Protect_UnProtect_Routine', PowerPoint does not support the Application.OnTime method, so I just shortened the code to: Call SaveVBProjectChanges
2. Private Sub SaveVBProjectChanges(), PowerPoint does not support the Application.EnableEvents method, so I just commented out the two lines:
   1. Application.EnableEvents = False
   2. Application.EnableEvents = True

-----------------
#If VBA7 Then
Private Sub Protect_UnProtect_Routine(ByVal hwnd As LongPtr, ByVal uMsg As Long, ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
Dim hCurrentDlg As LongPtr, hwndSysTab As LongPtr
#Else
Private Sub Protect_UnProtect_Routine(ByVal hwnd As Long, ByVal uMsg As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
Dim hCurrentDlg As Long, hwndSysTab As Long
#End If

Const TCM_FIRST = &H1300
Const TCM_SETCURSEL = (TCM_FIRST + 12)
Const TCM_SETCURFOCUS = (TCM_FIRST + 48)
Const EM_SETMODIFY = &HB9
Const BM_SETCHECK = &HF1
Const BST_CHECKED = &H1
Const BM_GETCHECK = &HF0
Const BM_CLICK = &HF5
Const WM_SETTEXT = &HC
Const WH_CBT = 5
Const GW_CHILD = 5

On Error GoTo errHandler

Call KillTimer(Application.hwnd, nIDEvent)

hCurrentDlg = nIDEvent

If sWinClassName = "VBAProject - Project Properties" Then

hwndSysTab = FindWindowEx(hCurrentDlg, 0, "SysTabControl32", vbNullString)
Call SendMessage(hwndSysTab, TCM_SETCURFOCUS, 1, 0)
Call SendMessage(hwndSysTab, TCM_SETCURSEL, 1, 0)

If SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_GETCHECK, 0, 0) = 0 Then
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1557), BM_SETCHECK, BST_CHECKED, 0)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1555), EM_SETMODIFY, True, 0)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(GetNextWindow(hCurrentDlg, GW_CHILD), &H1556), EM_SETMODIFY, True, 0)
End If

Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
Call SaveVBProjectChanges

ElseIf sWinClassName = "VBAProject Password" Then

Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), WM_SETTEXT, 0, sPassword)
Call SendMessage(GetDlgItem(hCurrentDlg, &H155E), EM_SETMODIFY, True, 0)
lHook = SetWindowsHookEx(WH_CBT, AddressOf Catch_DlgBox_Creation, 0, GetCurrentThreadId)
Call SendMessage(GetDlgItem(hCurrentDlg, &H1), BM_CLICK, 0, 0)
Call UnHook

End If

Exit Sub

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

-----------------------------------------------
Private Sub SaveVBProjectChanges()
On Error Resume Next
'Application.EnableEvents = False
Workbooks(sWorkbookName).Save
'Application.EnableEvents = True
End Sub

 

[danitouffaha]

Thank you Jaafar for sharing this!!

I have created a simple test, it works very good.

I open Monitor.xlsm which has your code above.
I have Applicator.xlsm where project is protected, I open it manually then I run the below code from Monitor.xlsm to test

Sub test()
    Dim test As String
    
    test = "Applicator.xlsm"
    LockVBProject(workbookName:=test, Password:=gadminPassword) = False
End Sub

And indeed the project for Applicator.xlsm is now unprotected, perfect!!!

Now when it comes to the real scenario, Monitor.xlsm is supposed to open Applicator.xlsm programmatically, unlock it and make some changes to its code then close it

....
        Set wbTarget = Workbooks.Open(targetFileName) 'this is Applicator.xlsm
        Call unlockVBAProject(wbTarget.Name)
....
wbTarget.Close Savechanges:=True

Sub unlockVBAProject(workbookName As String)
    'To un-lock the vbproject. (change workbook name as required)
        LockVBProject(workbookName:=workbookName, Password:=gadminPassword) = False

End Sub

Now in this case, I get the properties popup for Monitor.xlsm project and it does not Unprotect Applicator.xlsm project.

What am I missing? I spent countless number of hours trying to figure out why this is happening with no luck.
Can you please help?
Thanks
Dani

 

[Jaafar Tribak]

Thank you Jaafar for sharing this!!
What am I missing? I spent countless number of hours trying to figure out why this is happening with no luck.
Can you please help?
Thanks
Dani

Hi Dani,
I am sorry but locking/unlocking vba projects programmatically is very frustrating. It works inconsistently at best so I have decided to give up trying to make it work or taking this further.

Regards.