AW: Ist ein Makro in der Datei vorhanden?
18.09.2010 22:29:37
ransi
Hallo
Hier mein Versuch:
Alle Dateien nacheinander öffnen.
VBA-project ohne Schutz dann:
Untersuchen auf Module, Klassenmodule, Userforms.
Klassenmodule untersuchen ob mehr zeilen als die declarationszeilen vorhanden sind.
Wenn 1 von beiden dann die Datei aufnehmen in arr.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Public Sub test()
Dim FSO As Object
Dim WB As Workbook
Dim exlApp As Object
Dim vbCom As Object
Dim arr As Variant
Dim I As Integer
On Error GoTo raus
Set exlApp = CreateObject("Excel.Application")
Set FSO = CreateObject("Scripting.FilesystemObject")
Dim Datei As Object
With exlApp
Set WB = exlApp.Workbooks.Add
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
.ScreenUpdating = False
Redim arr(1 To FSO.getfolder("C:\Users\Dein_Pfad\makros").Files.Count)
For Each Datei In FSO.getfolder("C:\Users\Dein_Pfad\makros").Files
If FSO.getextensionname(Datei) = "xls" Then
Set WB = .Workbooks.Open(Datei, False, True)
If WB.VBProject.Protection = 0 Then
For Each vbCom In WB.VBProject.VBComponents
Select Case vbCom.Type
Case 1 To 3 'Klassenmodule, Userforms, Standardmodule
I = I + 1
Set arr(I) = Datei
Exit For
Case 100
If vbCom.CodeModule.CountOfLines > vbCom.CodeModule.CountOfDeclarationLines Then
I = I + 1
Set arr(I) = Datei
Exit For
End If
End Select
Next
End If
WB.Close False
End If
Next
End With
raus:
exlApp.Quit
Redim Preserve arr(I)
MsgBox Join(arr, vbCrLf)
End Sub
ransi