'Lock VB project for Excel 2000 or later

Option Explicit

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 uIDEvent As Long) As Long
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 TimerProc(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 = &H1555&
    IDConfirmPassword = &H1556&
    IDOK = &H1&
    sCaption = "Project Properties"

    '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

        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
        
        hwndProjectProp = hwndtmp
        hwndTab = GetDlgItem(hwndProjectProp, IDTab)
        lRet = SetFocusAPI(hwndTab)
        lRet = SendMessage(hwndTab, TCM_SETCURFOCUS, 1, ByVal 0&)

        timeout2 = Now() + TimeSerial(0, 0, TimeoutSecond)
        Do
            DoEvents
            hwndProjectProp2 = GetWindow(hwndProjectProp, GW_CHILD)
            hwndLockProject = GetDlgItem(hwndProjectProp2, IDLockProject)
        Loop While hwndLockProject = 0 And Now() < timeout2

        hwndPassword = GetDlgItem(hwndProjectProp2, IDPassword)
        hwndConfirmPassword = GetDlgItem(hwndProjectProp2, IDConfirmPassword)
        hwndOK = GetDlgItem(hwndProjectProp, IDOK)
        If (hwndProjectProp2 And hwndLockProject And hwndPassword _
            And hwndConfirmPassword And hwndOK) = 0 Then GoTo Continue

        lRet = SetFocusAPI(hwndLockProject)
        lRet = SendMessage(hwndLockProject, BM_SETCHECK, BST_CHECKED, ByVal 0&)
        lRet = SendMessage(hwndLockProject, BM_GETCHECK, 0, ByVal 0&)
        If lRet <> BST_CHECKED 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(hwndConfirmPassword)
        lRet = SendMessage(hwndConfirmPassword, EM_SETSEL, 0, ByVal -1&)
        lRet = SendMessage(hwndConfirmPassword, EM_REPLACESEL, 0, ByVal g_Password)

        pwd = String(260, Chr(0))
        lRet = SendMessage(hwndConfirmPassword, 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 LockProject(ByVal Project As Object, ByVal Password As String) As Long
    Dim timeout As Date
    Dim lRet As Long

    On Error GoTo ErrorHandler
    LockProject = 1
    If Project.Protection Then
        LockProject = 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
    Set Application.VBE.ActiveVBProject = Project
    If Not Application.VBE.ActiveVBProject Is Project Then
        GoTo ErrorHandler
    End If

    g_Result = 0
    lRet = SetTimer(0, 0, 100, AddressOf TimerProc)
    If lRet = 0 Then GoTo ErrorHandler
    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 LockProject = 0
    AppActivate Application.Caption
    LockWindowUpdate 0
    Exit Function

ErrorHandler:
    AppActivate Application.Caption
    LockWindowUpdate 0
End Function



Sub Test_LockProject()
    Workbooks.Add
    Select Case LockProject(ActiveWorkbook.VBProject, "password")
        Case 0: MsgBox "The project was locked."
        Case 2: MsgBox "The active project was already locked."
        Case Else: MsgBox "Error or timeout."
    End Select
End Sub