AW: Makroinformationen
13.04.2011 10:44:29
Rudi
Hallo,
dann teste mal
In ein Modul:
Option Explicit
Sub GetMakroList()
Dim FSO As Object, oFolder As Object
Dim strFolder As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Ordner wählen"
.AllowMultiSelect = False
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If strFolder = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strFolder)
ThisWorkbook.Sheets(1).Cells.Clear
prcFiles oFolder
prcSubFolders oFolder
End Sub
Private Sub prcFiles(oFolder)
Dim oFile As Object, wkb As Workbook
For Each oFile In oFolder.Files
If LCase(oFile) Like "*.xls" Then
Set wkb = Workbooks.Open(oFile)
MakroListe wkb
wkb.Close False
End If
Next
End Sub
Private Sub prcSubFolders(oFolder)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.SubFolders
prcFiles oSubFolder
prcSubFolders oSubFolder
Next
End Sub
Private Sub MakroListe(wkb As Workbook)
Dim vbc As Object, iCounter As Long, wks As Worksheet, sLine As String
Dim blnMakro As Boolean
Set wks = ThisWorkbook.Sheets(1)
On Error GoTo errhandler
For Each vbc In wkb.VBProject.VBComponents
With vbc.CodeModule
For iCounter = 1 To .CountOfLines
sLine = Trim(.Lines(iCounter, 1))
If sLine Like "Sub*(*)*" _
Or sLine Like "Public Sub*(*)*" _
Or sLine Like "Private Sub*(*)*" _
Or sLine Like "Function*(*)*" _
Or sLine Like "Public Function*(*)*" _
Or sLine Like "Private Function*(*)*" Then
blnMakro = True
With wks.Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0) = wkb.FullName
.Offset(1, 1) = sLine
End With
End If
Next iCounter
End With
Next vbc
If Not blnMakro Then
With wks.Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0) = wkb.FullName
.Offset(1, 1) = "No Makro"
End With
End If
errhandler:
If Err.Number > 0 Then
MsgBox Err.Description, , "Fehler"
End If
End Sub
Gruß
Rudi