VBA Read Password Protected Macros

Question

I'm trying to use VBA to open files that potentially have password protected macros. Below code can successfully detect the files with macros that have NO password, but fail to pick up the files with password protected macros. Any suggestions on how can I fix it?

Dim wb As Workbook
Set wb = Application.Workbooks.Open(EUC_Path, UpdateLinks:=False)
If wb.VBProject.VBComponents.Count > 0 Then
    ThisWorkbook.Worksheets(1).Range("F" & i).Value = "Yes"
Else
    ThisWorkbook.Worksheets(1).Range("F" & i).Value = "No"
End If

Thanks in advance.

---

Update: I realize that my above description wasn't very clear but my final goal is to actually read the number of lines in each macro, after determine whether the worksheet has macro to begin with. My code to check the number of lines is:

With wb.VBProject
    Number_Macro = 0
    For k = 1 To .VBComponents.Count
        Line_Count = .VBComponents.Item(k).CodeModule.CountOfLines
    next k
End with

Thus instead of detecting macro protection through error message, I have to be able to have a real access to the macro that is password protected. Can someone please advise me on that?

Thanks

Answer 1

You simply can't iterate the VBComponents collection of a protected VB project.

So you need a 3rd status:

Protected

You can verify whether a VBProject is protected through its Protection property.

If wb.VBProject.Protection = vbext_ProjectProtection.vbext_pp_none Then
    ' good to go
Else
    ' can't access components
End If

Actually, if a VBA project is protected, it's probably safe to assume it has VBA code, so "YES" would seem reasonable.

Also your logic is flawed: any Excel VBA project is going to have at least 2 components:

• Sheet1 (there's always at least 1 Worksheet object)
• ThisWorkbook (there's always at least 1 Workbook object)

By default there would actually be 4: Sheet1, Sheet2, Sheet3, and then ThisWorkbook. But that's up to user configuration / Excel settings so the number of modules doesn't mean anything - whether or not a project has macros.

I've just opened a .xlsx (no macros!) workbook, and .VBProject.VBComponents.Count returned 137.

To know if a workbook has macros, you need to find a standard module that has public members.

...but then, a document module (e.g. Sheet2, or ThisWorkbook) could reasonably not expose any macros per se, but still have VBA code that handles workbook or worksheet events - so you need to figure out if there's at least one document module with at least one procedure before you can confidently say "this file contains macros".

Answer 2

Your best bet would be to log the protected files, go back and manually unlock them, save a copy, then re-run those specific files.

Private Sub LogVBA_tst()
    Dim wb As Excel.Workbook
    Set wb = LogVBA(Environ("USERPROFILE") & "\Documents\Code\MSO\Excel\VBA Examples")
    wb.Activate
End Sub
Private Function LogVBA(EUC_Path As String) As Excel.Workbook
    'Required references
    '   VBIDE: Microsoft Visual Basic for Applications Extensibility 5.3
    '   VBScript_RegExp_55: Microsoft VBScript Regular Expressions 5.5
    Dim fso As Object, fldr As Object, fle As Object
    Set fso = CreateObject("Scripting.FilesystemObject")
    If Not fso.FolderExists(EUC_Path) Then Exit Function
    Set fldr = fso.GetFolder(EUC_Path)

    Dim logWB As Excel.Workbook: Set logWB = Application.Workbooks.Add
    Dim logWS As Excel.Worksheet: Set logWS = logWB.Worksheets.Add
    Const BlockPattern As String = "^( |\t)*(Private\s|Public\s|Friend\s)?(Static\s)?<Block>\s(.|\n)*?\n\s*End <Block>.*?$"
    Dim BlockRE As New VBScript_RegExp_55.RegExp: BlockRE.Global = True: BlockRE.IgnoreCase = True: BlockRE.MultiLine = True
    Const NameCOL As Long = 1
    Const HasVBACOL As Long = NameCOL + 1
    Const TotalLinesCOL As Long = HasVBACOL + 1
    Dim ComRE As New VBScript_RegExp_55.RegExp: ComRE.Pattern = "^( |\t)*'.*$": ComRE.Global = True: ComRE.IgnoreCase = True: ComRE.MultiLine = True
    Const ComLinesCOL As Long = TotalLinesCOL + 1
    Const CompsCtCOL As Long = ComLinesCOL + 1
    Const FunCtCOL As Long = CompsCtCOL + 1
    Const FunLinesCOL As Long = FunCtCOL + 1
    Const SubCtCOL As Long = FunLinesCOL + 1
    Const SubLinesCOL As Long = SubCtCOL + 1
    Const PropCtCOL As Long = SubLinesCOL + 1
    Const PropLinesCOL As Long = PropCtCOL + 1
    Const EnumCtCOL As Long = PropLinesCOL + 1
    Const EnumLinesCOL As Long = EnumCtCOL + 1
    Const TypeCtCOL As Long = EnumLinesCOL + 1
    Const TypeLinesCOL As Long = TypeCtCOL + 1
    Dim WBcompFlag As Boolean
    Const WBcodeCOL As Long = TypeLinesCOL + 1
    Const WBcodeLinesCOL As Long = WBcodeCOL + 1
    Const SheetCtCOL As Long = WBcodeLinesCOL + 1
    Const SheetLinesCOL As Long = SheetCtCOL + 1
    Const ModuleCtCOL As Long = SheetLinesCOL + 1
    Const ModuleLinesCOL As Long = ModuleCtCOL + 1
    Const ClassCtCOL As Long = ModuleLinesCOL + 1
    Const ClassLinesCOL As Long = ClassCtCOL + 1
    Const FormCtCOL As Long = ClassLinesCOL + 1
    Const FormLinesCOL As Long = FormCtCOL + 1
    Dim mtch As VBScript_RegExp_55.Match

    Dim LogNdx As Long: LogNdx = 1 'Log Header Row
    logWS.Cells(LogNdx, NameCOL).Value = "File Name"
    logWS.Cells(LogNdx, HasVBACOL).Value = "VBA Present"
    logWS.Cells(LogNdx, TotalLinesCOL).Value = "Total Line Count"
    logWS.Cells(LogNdx, ComLinesCOL).Value = "Comment Lines count"
    logWS.Cells(LogNdx, CompsCtCOL).Value = "Components with VBA"
    logWS.Cells(LogNdx, FunCtCOL).Value = "Functions"
    logWS.Cells(LogNdx, FunLinesCOL).Value = "Function Lines"
    logWS.Cells(LogNdx, SubCtCOL).Value = "Subs"
    logWS.Cells(LogNdx, SubLinesCOL).Value = "Sub Lines"
    logWS.Cells(LogNdx, PropCtCOL).Value = "Properties"
    logWS.Cells(LogNdx, PropLinesCOL).Value = "Property Lines"
    logWS.Cells(LogNdx, EnumCtCOL).Value = "Enumerations"
    logWS.Cells(LogNdx, EnumLinesCOL).Value = "Enum Lines"
    logWS.Cells(LogNdx, TypeCtCOL).Value = "User-Defined Data Types(UDT)"
    logWS.Cells(LogNdx, TypeLinesCOL).Value = "UDT Lines"
    logWS.Cells(LogNdx, WBcodeCOL).Value = "Workbook VBA"
    logWS.Cells(LogNdx, WBcodeLinesCOL).Value = "Workbook Lines"
    logWS.Cells(LogNdx, SheetCtCOL).Value = "Worksheets with VBA"
    logWS.Cells(LogNdx, SheetLinesCOL).Value = "Worksheet Lines"
    logWS.Cells(LogNdx, ModuleCtCOL).Value = "Modules"
    logWS.Cells(LogNdx, ModuleLinesCOL).Value = "Module Lines"
    logWS.Cells(LogNdx, ClassCtCOL).Value = "Class Modules"
    logWS.Cells(LogNdx, ClassLinesCOL).Value = "Class Lines"
    logWS.Cells(LogNdx, FormCtCOL).Value = "Forms"
    logWS.Cells(LogNdx, FormLinesCOL).Value = "Form Lines"
    LogNdx = LogNdx + 1 'Start Log Data

    Dim wb As Excel.Workbook, comp As VBIDE.VBComponent, CompCode As String, CodeLines As Variant, lc As Long, ProcessWB As Boolean
    For Each fle In fldr.Files
    Select Case LCase(Right(fle.Name, 4))
      Case ".xls", "xlsm", "xlsb" 'Filter files for excle VBA files
        logWS.Cells(LogNdx, NameCOL).Value = fle.Path
        Set wb = Application.Workbooks.Open(FileName:=fle.Path, UpdateLinks:=0, ReadOnly:=True, AddToMru:=False)

        If wb.HasVBProject Then 'Filter workbooks for ones with VBA
            ProcessWB = False
            If wb.VBProject.Protection = VBIDE.vbext_pp_locked Then
                logWS.Cells(LogNdx, HasVBACOL).Value = "Locked"
'                ToDo - Write: Private Function UnlockWBVBA(wb as Excel.Workbook) as Excel.Workbook
'                       Perform this step manually until implemented.
'                Set wb=UnlockWBVBA(wb)
'                ProcessWB = Not (wb Is Nothing)
            Else
                logWS.Cells(LogNdx, HasVBACOL).Value = "Yes"
                ProcessWB = True
            End If
        If ProcessWB Then
            For Each comp In wb.VBProject.VBComponents
                lc = comp.CodeModule.CountOfLines
            If lc > 0 Then 'Filter components for ones with lines
                logWS.Cells(LogNdx, TotalLinesCOL).Value = logWS.Cells(LogNdx, TotalLinesCOL).Value + lc
                logWS.Cells(LogNdx, CompsCtCOL).Value = logWS.Cells(LogNdx, CompsCtCOL).Value + 1
                Select Case comp.Type
                  Case VBIDE.vbext_ct_Document
                    On Error Resume Next
                    WBcompFlag = True: WBcompFlag = Not (comp.Properties("Columns").Name = "Columns")
                    On Error GoTo 0
                  If WBcompFlag Then 'Case Workbook
                    logWS.Cells(LogNdx, WBcodeCOL).Value = "Yes"
                    logWS.Cells(LogNdx, WBcodeLinesCOL).Value = lc
                  Else 'Case Worksheet
                    logWS.Cells(LogNdx, SheetCtCOL).Value = logWS.Cells(LogNdx, SheetCtCOL).Value + 1
                    logWS.Cells(LogNdx, SheetLinesCOL).Value = logWS.Cells(LogNdx, SheetLinesCOL).Value + lc
                  End If
                  Case VBIDE.vbext_ct_StdModule
                    logWS.Cells(LogNdx, ModuleCtCOL).Value = logWS.Cells(LogNdx, ModuleCtCOL).Value + 1
                    logWS.Cells(LogNdx, ModuleLinesCOL).Value = logWS.Cells(LogNdx, ModuleLinesCOL).Value + lc
                  Case VBIDE.vbext_ct_ClassModule
                    logWS.Cells(LogNdx, ClassCtCOL).Value = logWS.Cells(LogNdx, ClassCtCOL).Value + 1
                    logWS.Cells(LogNdx, ClassLinesCOL).Value = logWS.Cells(LogNdx, ClassLinesCOL).Value + lc
                  Case VBIDE.vbext_ct_MSForm
                    logWS.Cells(LogNdx, FormCtCOL).Value = logWS.Cells(LogNdx, FormCtCOL).Value + 1
                    logWS.Cells(LogNdx, FormLinesCOL).Value = logWS.Cells(LogNdx, FormLinesCOL).Value + lc
                End Select
                CompCode = comp.CodeModule.Lines(1, lc)

                'Parse Comments
                For Each mtch In ComRE.Execute(CompCode)
                    logWS.Cells(LogNdx, ComLinesCOL).Value = logWS.Cells(LogNdx, ComLinesCOL).Value + 1
                Next mtch

                'Parse Functions
                BlockRE.Pattern = Replace(BlockPattern, "<Block>", "Function")
                For Each mtch In BlockRE.Execute(CompCode)
                    logWS.Cells(LogNdx, FunCtCOL).Value = logWS.Cells(LogNdx, FunCtCOL).Value + 1
                    CodeLines = Split(mtch.Value, vbNewLine)
                    logWS.Cells(LogNdx, FunLinesCOL).Value = logWS.Cells(LogNdx, FunLinesCOL).Value + 1 + UBound(CodeLines) - LBound(CodeLines)
                Next mtch

                'Parse Subs
                BlockRE.Pattern = Replace(BlockPattern, "<Block>", "Sub")
                For Each mtch In BlockRE.Execute(CompCode)
                    logWS.Cells(LogNdx, SubCtCOL).Value = logWS.Cells(LogNdx, SubCtCOL).Value + 1
                    CodeLines = Split(mtch.Value, vbNewLine)
                    logWS.Cells(LogNdx, SubLinesCOL).Value = logWS.Cells(LogNdx, SubLinesCOL).Value + 1 + UBound(CodeLines) - LBound(CodeLines)
                Next mtch

                'Parse Properties
                BlockRE.Pattern = Replace(BlockPattern, "<Block>", "Property")
                For Each mtch In BlockRE.Execute(CompCode)
                    logWS.Cells(LogNdx, PropCtCOL).Value = logWS.Cells(LogNdx, PropCtCOL).Value + 1
                    CodeLines = Split(mtch.Value, vbNewLine)
                    logWS.Cells(LogNdx, PropLinesCOL).Value = logWS.Cells(LogNdx, PropLinesCOL).Value + 1 + UBound(CodeLines) - LBound(CodeLines)
                Next mtch

                'Parse Enumerations
                BlockRE.Pattern = Replace(Replace(Replace(BlockPattern, "<Block>", "Enum"), "|Friend\s", ""), "(Static\s)?", "")
                For Each mtch In BlockRE.Execute(CompCode)
                    logWS.Cells(LogNdx, EnumCtCOL).Value = logWS.Cells(LogNdx, EnumCtCOL).Value + 1
                    CodeLines = Split(mtch.Value, vbNewLine)
                    logWS.Cells(LogNdx, EnumLinesCOL).Value = logWS.Cells(LogNdx, EnumLinesCOL).Value + 1 + UBound(CodeLines) - LBound(CodeLines)
                Next mtch

                'Parse User-Defined Types
                BlockRE.Pattern = Replace(Replace(Replace(BlockPattern, "<Block>", "Type"), "|Friend\s", ""), "(Static\s)?", "")
                For Each mtch In BlockRE.Execute(CompCode)
                    logWS.Cells(LogNdx, TypeCtCOL).Value = logWS.Cells(LogNdx, TypeCtCOL).Value + 1
                    CodeLines = Split(mtch.Value, vbNewLine)
                    logWS.Cells(LogNdx, TypeLinesCOL).Value = logWS.Cells(LogNdx, TypeLinesCOL).Value + 1 + UBound(CodeLines) - LBound(CodeLines)
                Next mtch
            End If: Next comp
        End If 'If ProcessWB
        Else: logWS.Cells(LogNdx, HasVBACOL).Value = "No"
        End If 'If wb.HasVBProject

        If Not (wb Is Nothing) Then wb.Close Savechanges:=False
        LogNdx = LogNdx + 1
      Case "xlsx"
        logWS.Cells(LogNdx, NameCOL).Value = fle.Path
        logWS.Cells(LogNdx, HasVBACOL).Value = "Skipped"
        LogNdx = LogNdx + 1
    End Select: Next fle
    logWS.UsedRange.AutoFilter
    logWS.UsedRange.EntireColumn.AutoFit
    Set LogVBA = logWB
End Function