VBA读取密码保护宏

Question

我试图使用VBA来打开可能具有密码保护宏的文件。下面的代码可以成功地检测到那些没有密码的宏的文件，但是无法找到带有密码保护的宏的文件。有什么我能解决的建议吗？

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

提前谢谢。

更新:我意识到上面的描述不是很清楚，但我的最终目标是在确定工作表是否有宏之后，实际读取每个宏中的行数。我检查行数的代码是：

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

因此，与其通过错误消息检测宏保护，我还必须能够真正访问受密码保护的宏。有人能给我个建议吗？

谢谢

Answer 1

您根本不能迭代受保护的VB项目的VBComponents集合。

所以你需要第三种状态：

受保护

可以验证VBProject是否通过其Protection属性受到保护。

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

实际上，如果一个VBA项目受到保护，那么假设它有VBA代码是安全的，所以“是”似乎是合理的。

此外，您的逻辑也有缺陷：任何 Excel项目都至少有两个组件：

• Sheet1 (总是至少有一个Worksheet对象)
• ThisWorkbook (总是至少有一个Workbook对象)

默认情况下，实际上有4：Sheet1、Sheet2、Sheet3，然后是ThisWorkbook。但是这取决于用户配置/ Excel设置，因此模块的数量并不意味着什么--不管项目是否有宏。

我刚刚打开了一个.xlsx (没有宏！)工作簿，.VBProject.VBComponents.Count返回137。

要知道工作簿是否有宏，您需要找到一个具有公共成员的标准模块。

然后，...but文档模块(例如，Sheet2或ThisWorkbook)可以合理地不公开任何宏本身，但是仍然有处理工作簿或工作表事件的VBA代码--因此您需要弄清楚是否至少有一个文档模块具有至少一个过程，然后才能自信地说“这个文件包含宏”。

Answer 2

您最好的选择是记录受保护的文件，返回并手动解锁，保存副本，然后重新运行这些特定的文件。

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