Results 1 to 5 of 5
  1. #1
    Lounger
    Join Date
    Jan 2001
    Location
    Newfoundland
    Posts
    41
    Thanks
    4
    Thanked 0 Times in 0 Posts

    Excel 2010 - Locking VBA Project

    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.

  2. #2
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    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

  3. The Following User Says Thank You to sdckapr For This Useful Post:

    AnneD (2011-06-05)

  4. #3
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    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
    Regards,
    Rory

    Microsoft MVP - Excel

  5. The Following 3 Users Say Thank You to rory For This Useful Post:

    AnneD (2011-06-07),RetiredGeek (2011-06-06),sdckapr (2011-06-06)

  6. #4
    WS Lounge VIP sdckapr's Avatar
    Join Date
    Jul 2002
    Location
    Pittsburgh, Pennsylvania, USA
    Posts
    11,225
    Thanks
    14
    Thanked 342 Times in 335 Posts
    Thanks, Rory. I am not sure if I will ever use it, but it is nice to know that it can be done!

    Steve

  7. #5
    WS Lounge VIP rory's Avatar
    Join Date
    Dec 2000
    Location
    Burwash, East Sussex, United Kingdom
    Posts
    6,280
    Thanks
    3
    Thanked 191 Times in 177 Posts
    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.
    Regards,
    Rory

    Microsoft MVP - Excel

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •