AW: Noch zwei Bitten
19.06.2011 15:10:03
Nepumuk
Hallo,
wo hast du denn die ganzen Makros her, wenn du so eine kleine Anpassung nicht gebacken bekommst?
Copy & Paste ? ;-)
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public Sub Macroliste()
Dim objVBC As Object, objDIC As Object
Dim objWorkbook As Workbook, objSheet As Worksheet
Dim strMacroname As String, strTemp As String
Dim strPath As String
Dim lngLine As Long, lngFileCount As Long, lngRow As Long
Dim blnMakroFound As Boolean
Set objSheet = ActiveSheet
Set objDIC = CreateObject("Scripting.Dictionary")
lngRow = 3
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
.ShowWindowsInTaskbar = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
strTemp = objSheet.Cells(1, 1).Value
objSheet.Cells.Clear
objSheet.Cells(1, 1).Value = strTemp
With .FileSearch
.NewSearch
.Filename = "*.xls"
.LookIn = objSheet.Cells(1, 1).Value
.SearchSubFolders = True
.Execute
For lngFileCount = 1 To .FoundFiles.Count
strPath = .FoundFiles(lngFileCount)
lngRow = lngRow + 1
objSheet.Cells(lngRow, 1).Value = Dir$(strPath)
objSheet.Cells(lngRow, 1).Font.Bold = True
objSheet.Cells(lngRow, 2).Value = strPath
Set objWorkbook = Workbooks.Open(Filename:=strPath, _
UpdateLinks:=0, ReadOnly:=True, Password:="", WriteResPassword:="")
If Err.Number <> 0 Then
lngRow = lngRow + 1
objSheet.Cells(lngRow, 1).Value = "Die Mappe ist Kennwortgeschützt"
Err.Clear
Else
Err.Clear
blnMakroFound = False
objDIC.RemoveAll
If Not objWorkbook.VBProject.Protection Then
For Each objVBC In objWorkbook.VBProject.VBComponents
With objVBC.CodeModule
strMacroname = ""
For lngLine = 1 To .CountOfLines
If .ProcOfLine(lngLine, 0) <> strMacroname Then
strMacroname = .ProcOfLine(lngLine, 0)
If Not objDIC.Exists(strMacroname) Then
objDIC.Add strMacroname, vbNullString
lngRow = lngRow + 1
objSheet.Cells(lngRow, 1).Value = strMacroname
objSheet.Cells(lngRow, 2).Value = strPath
End If
blnMakroFound = True
End If
Next
End With
Next
If Not blnMakroFound Then
lngRow = lngRow + 1
objSheet.Cells(lngRow, 1).Value = "Keine Makros gefunden"
End If
Else
lngRow = lngRow + 1
objSheet.Cells(lngRow, 1).Value = "Das VBA-Projekt ist Kennwortgeschützt"
End If
End If
objWorkbook.Close SaveChanges:=False
lngRow = lngRow + 1
Next
End With
objSheet.Columns.AutoFit
.ScreenUpdating = True
.EnableEvents = True
.ShowWindowsInTaskbar = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Set objVBC = Nothing
Set objDIC = Nothing
Set objWorkbook = Nothing
Set objSheet = Nothing
End Sub
Gruß
Nepumuk