Is there a way to check if a workbook is protected before try to open it.
Here is my code but I have no Idea of the way (if it is possible)
Sub MySub()
Dim Wb As Workbook
For i = 14 To Cells(Rows.Count, 1).End(xlUp).Row
'I Would like to check if the workbook is Protected here
Set Wb = GetObject(Cells(i, 4).Value)
Wb.Open
End Sub
Note : In this code Cells(i,4).Value will be equal to the workbooks path..
Had a bit more of a think about this and came up with the following - although will need a lot more testing and probably a bit of modification. I don't like that the default result is that it is protected but in my quick test I could only get a non-protected file to list its items.
This works by converting the file to a zip file, trying to navigate its contents and then converting back to the original type. I've only tested it with xlsx files but principle should be the same for xlsm as well. Once converted I use a shell to explore the zip contents. An unprotected file will return a list of its contents, where as a protected one won't.
Public Function IsWorkbookProtected(WorkbookPath As String) As Boolean
Dim fileExtension As String
Dim tmpPath As Variant
Dim sh As Object
Dim n
fileExtension = Right(WorkbookPath, Len(WorkbookPath) - InStrRev(WorkbookPath, "."))
tmpPath = Left(WorkbookPath, InStrRev(WorkbookPath, ".")) & "zip"
Name WorkbookPath As tmpPath
Set sh = CreateObject("shell.application")
Set n = sh.Namespace(tmpPath)
IsWorkbookProtected = Not n.Items.Count > 0
Name tmpPath As WorkbookPath
End Function
Called using
Sub test()
Dim FolderPath As String
Dim fPath1 As String, fPath2 As String
FolderPath = "ParentFolder"
' protected
fPath1 = FolderPath & "\testProtection.xlsx"
' unprotected
fPath2 = FolderPath & "\testProtection - Copy.xlsx"
Debug.Print fPath1, IsWorkbookProtected(fPath1)
Debug.Print fPath2, IsWorkbookProtected(fPath2)
End Sub
Output to immediate window:
ParentFolder\testProtection.xlsx True
ParentFolder\testProtection - Copy.xlsx False
This was a brief test into exploring the issue and I will state that this is most likely not a conclusive nor fool-proof answer. Ideally I'd want to traverse the zip folder contents and test for the 'EncryptedPackage' but NameSpace wasn't returning any items. There may be another way of being able to do it but I haven't investigated further.
Protected Excel file zip contents:
Non-Protected Excel file zip contents:
Update with timer tests
Using a timer code from TheSpreadSheetGuru
Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim StartTime As Double
Dim SecondsElapsed As Double
'Remember time when macro starts
StartTime = Timer
' Debug.Print "IsWorkbookProtected"
Debug.Print "testOpen"
'*****************************
'Insert Your Code Here...
'*****************************
' Call testZip
Call testOpen
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"
End Sub
and using the following code to test by opening the files, testing for protection and closing
Sub testOpen()
Dim wb As Workbook
Dim FolderPath As String
Dim fPath1 As String, fPath2 As String
Dim j As Long
FolderPath = "FolderPath"
Application.ScreenUpdating = False
' protected
fPath1 = FolderPath & "\testProtection.xlsx"
' unprotected
fPath2 = FolderPath & "\testProtection - Copy.xlsx"
For j = 1 To 2
On Error Resume Next
Set wb = Workbooks.Open(Choose(j, fPath1, fPath2), , , , "")
Debug.Print Choose(j, fPath1, fPath2), wb Is Nothing
wb.Close
On Error GoTo 0
Next j
Application.ScreenUpdating = True
End Sub
I got the following times:
Run this multiple times and got similar results
This is completely unsupported through any documentation but I think I found something interesting. I'm curious for other opinions on this.
Hypothesis
So, each time I went through all my file properties, there was one property that seemingly changed when a file was password protected, this was property 42 (being the "Program name"), part of the extended file properties. See screenshot below (by @Tom), where the left is an unprotected file and the right is protected.
Everytime I unprotected a workbook, a value showed up, e.g "Microsoft Excel" or even sometimes "Microsoft Excel Online". However, on all cases I protected the workbook, the value was empty. Hence, that left me thinking that looking at this specific property is telling us in some way that the file is protected when the property is empty. Might this because the property can't be read because of the protection?
With the help of @Tom we found that this property's index can differ. While on my system this property has got index 42, it appeared that at Tom's system it would sit under 8. Therefor he kindly implemented a smart loop to return the right index before looping the files. Noteworthy: The property's name is language dependent! For Dutch, I would look for "Programmanaam" for example.
Code
Using the following code we can go through a specific folder and loop files to return the value of this specific property:
Sub MySub()
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("C:\Users\...\")
Dim i as long, x as long
For i = 0 To 288
If oDir.GetDetailsOf(oDir.Items, i) = "Program name" Then
x = i
Exit For
End If
Next i
For Each sFile In oDir.Items
If oDir.GetDetailsOf(sFile, x) = "" Then
Debug.Print sFile.Name & " is protected"
Else
Debug.Print sFile.Name & " is unprotected and can be openened"
End If
Next
End Sub
To adapt that a bit more to loop a range and check a bunch of workbook names that could look like:
Working code looks like:
Sub MySub()
Dim MainPath As String: MainPath = "C:\Users\...\"
Dim i As Long, x As Long
Dim oDir As Object: Set oDir = CreateObject("Shell.Application").Namespace(CStr(MainPath))
'Get the right index for property "Program Name"
For i = 0 To 288
If oDir.GetDetailsOf(oDir.Items, i) = "Program Name" Then
x = i
Exit For
End If
Next i
'Loop the range of workbooks and check whether or not they are protected
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If oDir.GetDetailsOf(oDir.Items.Item(CStr(.Cells(i, 1))), x) = "" Then
Debug.Print .Cells(i, 1) & " is protected"
Else
Debug.Print .Cells(i, 1) & " is unprotected and can be openened"
'Open your workbook here?
End If
Next i
End With
End Sub
Note: Please notice the use of
Cstr()on both the MainPath and the cell's value. It's as far as I know not very clear why, but without it, the code will return an 'Error 445: Object doesn't support this action' Update: Check this question for some more insight on this specific issue.
Example
For example, I have the following workbooks, with Map2 and Map5 protected:
Immediate window after running the first macro:
Next I only protected map1 and map3 with the following result:
Conclusion
Hypothesis proven? I don't know, but on my end there has not been a single time the hypothesis has been proven wrong. Again, there is no documentation on this. But this might just be your way into knowing very quickly if a workbook is protected or not.
Btw, I borrowed some code form here
What I would like to propose is using file signature, the magic string of bytes that – in addition to file extension – helps operating systems and programs determine what they're dealing with. According to the trusted TrID database, the magic string defining an encrypted Excel file (aka 'Encrypted OLE2 / Multistream Compound File') consists of the following eight bytes: D0 CF 11 E0 A1 B1 1A E1.
Knowing this we can check for their existence as follows:
Public Function IsPasswordProtected(strFilePath As String) As Boolean
' Open file for byte reading, check length
Dim fileInt As Integer: fileInt = FreeFile
Open strFilePath For Binary Access Read As #fileInt
If LOF(fileInt) < 8 Then
Exit Function
End If
' Fetch the first bytes
Dim arrFile(0 To 7) As Byte
Get #fileInt, , arrFile
Close #fileInt
' Compare with Encrypted OLE2 / Multistream Compound File magic
' D0 CF 11 E0 A1 B1 1A E1
Dim arrSignature(0 To 7) As Byte, i As Integer
For i = LBound(arrSignature) To UBound(arrSignature)
arrSignature(i) = Choose(i + 1, &HD0, &HCF, &H11, &HE0, &HA1, &HB1, &H1A, &HE1)
Next
If StrConv(arrFile, vbUnicode) = StrConv(arrSignature, vbUnicode) Then
IsPasswordProtected = True
End If
End Function
Please note the above does not contain proper error handling. Also, bear in mind that the signature is also shared with unprotected XLS files and so will lead to correct conclusions only for XLSX files.
Maybe this will not fully satisfy You, but maybe help a little bit.
Sub checkif()
On Error GoTo ErrHand
Dim obj As Object
Dim strFileName
strFileName = "filepath"
Set obj = Workbooks.Open(strFileName, , , , "")
Exit Sub
ErrHand:
If Err() = 1004 Then
MsgBox "Protected"
End If
End Sub
