Solved

vba script to unlock/un-protect spreadsheets in a folder

Posted on 2012-03-18
5
582 Views
Last Modified: 2013-07-22
Hi,
I have a booring task to go though the spreadsheets in a folder and un-protect them (including vba project/modules, workbook and worksheet level protection).
I have a list of applicable passwords for all workbook, worksheet and VBA protection.

I was wondering if some one has already written a script that could be useD?


thanks
0
Comment
Question by:student225
5 Comments
 
LVL 92

Assisted Solution

by:Patrick Matthews
Patrick Matthews earned 166 total points
ID: 37735102
Workbook and worksheet protection passwords are easy.

The disabling the VBA project password from a macro, however, probably falls into the "you can't" category.

Theoretically you could try it with SendKeys, but I wouldn't put my faith in that.

You might want to look at this thread, which has a couple of Microsoft MVPs (xld and macropod) participating: http://www.vbaexpress.com/forum/showthread.php?t=30687

It can possibly be made to work, but as xld points out, if your VBProjects don't load in the order you're expecting, you're screwed.
0
 
LVL 41

Assisted Solution

by:dlmille
dlmille earned 166 total points
ID: 37735337
VBA Project is tricky.  Here's a set of functions I put together for a solution about 6 months ago, re: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_26875534.html

I had a lot of difficulties getting the VBA project unlock working correctly, so I echo matthewspatrick's comments.  I have code in the attached that does this, and perhaps with matthewspatrick's links, this adds some additional insight.

-------------------------------

I took a few of those functions and developed a script for you.  The first button prompts you for a folder, then puts those files in column A.  You can then put the workbook password, password for all sheets (have to add sophistication if different sheet names have passwords) and VBA project password.

I've commented out the calls to send keys to the VBA project, though you can try that code.  However, unlocking the workbooks and worksheets works very systematically.

Here's the code:
Option Explicit

Public Sub listFilesColA()
Dim wkb As Workbook
Dim wks As Worksheet
Dim dialogFile As FileDialog
Dim dirName As String
Dim fName As String
Dim strPath
Dim i As Long

    strPath = ThisWorkbook.Path & "\"
    Set wkb = ThisWorkbook
    Set wks = wkb.Worksheets("FolderIntel")

    wks.Range("A2:A" & wks.Rows.Count).Clear

    ' Open the file dialog
    Set dialogFile = Application.FileDialog(msoFileDialogFolderPicker)
    With dialogFile
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewTiles
        .InitialFileName = strPath
        .Title = "Select Folder of Files to Unprotect"
        .Show
    End With
    If dialogFile.SelectedItems.Count > 0 Then
        dirName = dialogFile.SelectedItems(1)

        fName = Dir(dirName & "\*.xls*")    'get all Excel type files

        Do While fName <> ""
            wks.Range("A2").Offset(i, 0).Value = dirName & "\" & fName
            fName = Dir()
            i = i + 1
        Loop
        wks.Columns("A").AutoFit
    End If

    'cleanup
    Set dialogFile = Nothing

End Sub
Sub lockFilesInList()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim r As Range
Dim oApp As Excel.Application
Dim oWkb As Excel.Workbook
Dim oWks As Excel.Worksheet

    Set wkb = ThisWorkbook
    Set wks = wkb.Worksheets("FolderIntel")

    Set rng = wks.Range("A2", wks.Range("A" & wks.Rows.Count).End(xlUp))

    Set oApp = CreateObject("Excel.Application")
    oApp.EnableEvents = False

    For Each r In rng
        Set oWkb = oApp.Workbooks.Open(r.Value)
        For Each oWks In oWkb.Worksheets
            Call LockDownSettings(oWks, r.Offset(, 2).Value)
        Next oWks
        Call ProtectWorkbook(oWkb, r.Offset(, 1).Value)
        'Call SetVBProjectPassword(oWkb, r.Offset(, 3).Value) 'Attempts to lock VBA Password
        oWkb.Close savechanges:=True
    Next r

    oApp.Quit
    Set oApp = Nothing
End Sub
Sub unlockAllInColumnA()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rng As Range
Dim r As Range
Dim oApp As Excel.Application
Dim oWkb As Excel.Workbook
Dim oWks As Excel.Worksheet

    Set wkb = ThisWorkbook
    Set wks = wkb.Worksheets("FolderIntel")

    Set rng = wks.Range("A2", wks.Range("A" & wks.Rows.Count).End(xlUp))

    Set oApp = CreateObject("Excel.Application")
    oApp.EnableEvents = False

    For Each r In rng
        Set oWkb = oApp.Workbooks.Open(r.Value)
        Call unProtectWorkbook(oWkb, r.Offset(, 1).Value)
        For Each oWks In oWkb.Worksheets
            Call UnlockSettings(oWks, r.Offset(, 2).Value)
        Next oWks
        'Call UnlockTargetVBProject(oWkb, r.Offset(, 3).Value) 'Attempts to unlock VBA Password
        oWkb.Close savechanges:=True
    Next r

    oApp.Quit
    Set oApp = Nothing
End Sub

Open in new window


And here's the lock/unlocking code:
Option Explicit

Const allShtPwd = "Password"
Public Sub ProtectWorkbook(wkb As Workbook, pswd As String)

    wkb.Protect Password:=pswd, Structure:=True, Windows:=False   'you can set all the settings you want to restrict, here, or set them once at the user interface

End Sub
Public Sub unProtectWorkbook(wkb As Workbook, pswd As String)
    wkb.Unprotect Password:=pswd
End Sub
Public Sub LockDownSettings(mySheet As Worksheet, Optional mypwd As Variant = allShtPwd, Optional enableOutline As Variant = True, Optional protectOpt As Variant = "")
'if the optional pwd exists, then there could be different passwords on different sheets, enableOutlining default is TRUE, protectOpt default is blank
Dim myCell As Range
Dim bDrawingObjects As Boolean, bContents As Boolean, bScenarios As Boolean, bUserInterfaceOnly As Boolean, bAllowFormattingCells As Boolean
Dim bAllowFormattingColumns As Boolean, bAllowFormattingRows As Boolean, bAllowInsertingColumns As Boolean, bAllowInsertingRows As Boolean
Dim bAllowInsertingHyperlinks As Boolean, bAllowDeletingColumns As Boolean, bAllowDeletingRows As Boolean, bAllowSorting As Boolean
Dim bAllowFiltering As Boolean, bAllowUsingPivotTables As Boolean

        'Now protect the sheet with appropriate options (note, either DrawingObjects, Contents, or Scenarios MUST BE TRUE for Protect to lock the worksheet
        mySheet.Protect Password:=mypwd

letsContinue:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub

errHandler:
    MsgBox Err.Number & ":" & Err.Description
    Resume letsContinue
End Sub
Public Sub UnlockSettings(mySheet As Worksheet, Optional pwd As Variant)
'if the optional pwd exists, then there could be different passwords on different sheets
Dim mypwd As String

    If IsMissing(pwd) Then
        mypwd = allShtPwd
    Else
        mypwd = pwd
    End If

    On Error Resume Next
    mySheet.Unprotect Password:=mypwd

End Sub
Public Sub UnlockTargetVBProject(aWB As Workbook, vbProjPassword As String)
'source: adapted from http://www.excelforum.com/excel-programming/762424-sendkeys-unlocks-vba-project-but-still-pops-up-password-prompt.html
'This procedure will unprotect an already opened target workbook passed in as the argument
'It will call the UnprotectVBProject() procedure immediately below

Dim wbName As Variant
Dim vbaProj As Object
Dim oWin As Object
Dim X As Integer

    On Error GoTo ErrorHandler

    'Assign an object ref to the target's VBA project
    Set vbaProj = aWB.VBProject
    wbName = aWB.Name

    'Close any open code windows
    For Each oWin In vbaProj.VBE.Windows
        If InStr(oWin.Caption, "(") > 0 Then oWin.Close
    Next oWin

    'Application.VBE.MainWindow.Visible = False

    'Check to see if the VBA project is already unlocked
    If vbaProj.Protection <> 1 Then
        'MsgBox "Target file's VBA Project is already unlocked.", 0
        Exit Sub
    ElseIf vbaProj.Protection = 1 Then
        'We found the project to be locked
        On Error Resume Next
        Do While X < 4
            If vbaProj.Protection <> 1 Then
                'MsgBox "The VBA project for " & wbName & " was unprotected successfully. Programming update will start now.", 64
                'MsgBox "when done unlocking, X is: " & X
                Exit Do
            End If
            'By duplicating the lines below, I'm able to reduce the number of times this Do loop is run.
            UnprotectVBProject aWB, vbProjPassword
            Application.Wait Now + TimeValue("00:00:01")    'added by dlmille of E-E
            UnprotectVBProject aWB, vbProjPassword
            Application.Wait Now + TimeValue("00:00:01")    'added by dlmille of E-E
            X = X + 1
        Loop
        On Error GoTo 0
    End If

ErrorExit:
    Set vbaProj = Nothing
    Exit Sub

ErrorHandler:
    Select Case Err.Number
    Case 1004
        MsgBox "You will need to set the " & _
               "{ TRUST ACCESS TO VISUAL BASIC PROJECT } setting" & vbNewLine & _
               "When the dialog appears, go to the Trusted Sources tab, " & _
               "check the setting, click OK, and re-start the update on a new copy of the old workbook again.", 64
        SendKeys "%T", True
        SendKeys "M", True
        SendKeys "S", True
    Case Else
        MsgBox Err.Description
    End Select

    Resume ErrorExit

End Sub
Public Sub UnprotectVBProject(WB As Workbook, ByVal Password As String)
'source: adapted from http://www.excelforum.com/excel-programming/762424-sendkeys-unlocks-vba-project-but-still-pops-up-password-prompt.html
Dim vbProj As Object

    On Error GoTo ErrorHandler

    Application.ScreenUpdating = False
    Set vbProj = WB.VBProject

    'Check to see if VBA project is already unlocked
    If vbProj.Protection <> 1 Then Exit Sub

    'Activate chosen VBA Project
    Set Application.VBE.ActiveVBProject = vbProj

    'SendKeys is the only way
    Application.SendKeys Password & "~~{ESC}"
    Application.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute

    'Not the right password
    If vbProj.Protection = 1 Then
        SendKeys "%{F11}", True
    End If

    ' Clean up
    Password = ""
    Application.ScreenUpdating = True
    Set vbProj = Nothing

    Exit Sub

ErrorHandler:
    MsgBox Err.Description, 64
End Sub

Public Sub SetVBProjectPassword(WB As Workbook, ByVal Password As String)
'source: adapted from http://www.excelforum.com/excel-programming/762424-sendkeys-unlocks-vba-project-but-still-pops-up-password-prompt.html
' used during making of new protected app, if user changes password

Dim VBP As Object, oWin As Object
Dim wbActive As Workbook
Dim i As Integer, vbext_pp_locked As Integer

    Set VBP = WB.VBProject
    Set wbActive = ActiveWorkbook

    'can't do it if locked!
    If VBP.Protection = 1 Then Exit Sub

    Application.ScreenUpdating = False

    ' close any code windows to ensure we hit the right project
    For Each oWin In VBP.VBE.Windows
        If InStr(oWin.Caption, "(") > 0 Then oWin.Close
    Next oWin

    WB.Activate
    ' now use lovely SendKeys to set the project password
    Application.OnKey "%{F11}"
    'SendKeys "%{F11}%TE+{TAB}{RIGHT}%V{+}{TAB}" & Password & "{TAB}" & _
     'Password & "~%{F11}", True
    SendKeys "%{F11}%TE+{TAB}{RIGHT}%V{+}{TAB}" & Password & "{TAB}" & Password, True
    SendKeys "%{F11}"    ' revert back to sheet"
    ' leave no evidence of the password
    Password = ""
    ' go back to the previously active workbook
    wbActive.Activate
End Sub

Open in new window


See attached demonstration workbook.  Hopefully this at least gets you some starting structure from which to work with.

Cheers,

Dave
unlockAllInFolder-r1.xls
0
 
LVL 85

Accepted Solution

by:
Rory Archibald earned 168 total points
ID: 37737276
Purely on the grounds that I hate Sendkeys:

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

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&)

      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(Workbooks("some.xlam").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

Open in new window

0

Featured Post

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

13 Experts available now in Live!

Get 1:1 Help Now