Excel 2010 – Locking VBA Project

Topic

New Reply

Can the locked status of a VBA project be controlled with VBA code?

When the file is opened all the worksheet tabs are hidden. There is an activex command button to accept terms of use. If the user presses Accept, the worksheet tabs are displayed. Before the user presses Accept, I would like to restrict access to the VBA project. Once the user presses Accept, I would like to unlock the project.

Any help would be appreciated.

Reply | Quote

Replies

As far as I know, VBA does not have access to unlocking the project. Instead of unlocking the project, you could have the code popup a messagebox giving the user the password to the project…

Steve

Reply | Quote

It can be done with API calls, but it’s not trivial code:

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 = 5

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&)
        sCaption = " - Project Properties"
        sCaption = g_ProjectName & sCaption
        
        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

Reply | Quote

Thanks, Rory. I am not sure if I will ever use it, but it is nice to know that it can be done!

Steve

Reply | Quote

TO be honest, I don’t know how stable it is – I cobbled it together from a piece of code I have to lock projects.

Reply | Quote