Prozeduren auflisten
Ich moechte das Makro so erweitern, dass es nicht ein
bestimmtes Makro sucht und loescht, sondern in allen Modulen,
die es brav aufsucht, alle darin enthaltenen Makros auflsitet.
Kannst du mir nochmal einen Tipp geben?
Hallo Erich,
getestet auf XL2000. Nicht getestet: freigegeben Mappen, Mappen mit
Passwort, gelistete Prozeduren > 65536 Zeielen, ob da der
Spaltenwechsel funktionirt, u.v.m.
Rückmeldung, bei welchen zu öffnenden Dateien oder Prozeduren es
Probleme gibt wäre sehr nett.
In der Statusbar wird der Fortschritt angezeigt.
Auskommentierter Code wird blau angezeigt.
Im Anhang bin ich einen anderen Weg gegangen, Code funktioniert auch,
allerdings kommt Fehler wenn eine Property erkannt wird. Und „On Error“ funktioniert nicht. Also mehr
was zum lernen/üben.
In ein Standardmodul:
Option Explicit
Public Zei As Long, Spa As Integer
Sub ProzedurenAuflisten()
'listet alle Prozeduren aller offenen Workbooks auf
Dim wb As Workbook
ThisWorkbook.Worksheets("Tabelle1").Activate
Zei = 1
Spa = 1
Cells.ClearContents
[A1:smiley:1] = Split("Mappe Modul Prozedur Code")
[A1:smiley:1].Copy Destination:=[E1:IV1]
For Each wb In Workbooks
MsgBox wb.Name
'If UCase(wb.Name) "PERSONL.XLS" And wb.Name ThisWorkbook.Name Then
Call ListProcedures(wb)
'End If
Next wb
End Sub
Sub MappenOeffnenProzedurenAuflisten()
'Öffnet alle Dateien im Ordner "Pfad" und listet alle Prozeduren auf.
'Code 2007 by Reinhard
Dim wb, Pfad As String, fs, N As Long, ws As Worksheet
Dim oldStatusBar
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Fehler
'Pfad = "C:\Download"
Pfad = ThisWorkbook.Path
Set ws = ThisWorkbook.Worksheets("Tabelle1")
Set fs = Application.FileSearch
Call MappenSchliessen
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Zei = 1
Spa = 1
With ws
.Cells.ClearContents
.Cells.Font.ColorIndex = xlAutomatic
.[A1:smiley:1] = Split("Mappe Modul Prozedur Code")
.[A1:smiley:1].Copy Destination:=.[E1:IV1]
End With
With fs
.LookIn = Pfad
.Filename = "\*.xls"
.SearchSubFolders = True
.Execute
'For N = 1 To .FoundFiles.Count
For N = 1 To 10
If InStr(.FoundFiles(N), "\Personl.xls") = 0 And InStr(.FoundFiles(N), "\" & ThisWorkbook.Name) = 0 Then
Workbooks.Open .FoundFiles(N), 0, True
Set wb = ActiveWorkbook
'If UCase(wb.Name) "PERSONL.XLS" And wb.Name ThisWorkbook.Name Then
Application.StatusBar = "Bearbeite gerade " & N & " / " & .FoundFiles.Count & "Dateien."
Call ListProcedures2(wb)
wb.Close savechanges:=False
'End If
End If
Next N
End With
ws.Rows(1).Font.Bold = True
ws.Rows("2:2").Select
ActiveWindow.FreezePanes = True
ws.Range("A1").Select
Fehler:
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Sub ListProcedures2(ByVal wb As Workbook)
'Code 2007 by Reinhard
Dim VBCodeMod As CodeModule, lngStartLine As Long, strMsg As String
Dim strModName As String, CMdl, Zeile As Long, Spalte As Integer
Dim N As Long, Von As Long, Bis As Long, Prozedur As String
Dim ws As Worksheet
Call ZeileSpalte
Set ws = ThisWorkbook.Worksheets("Tabelle1")
ws.Cells(Zei, Spa) = wb.Name
On Error Resume Next
For Each CMdl In wb.VBProject.VBComponents
ws.Cells(Zei, Spa + 1) = CMdl.Name
Set VBCodeMod = wb.VBProject.VBComponents(CMdl.Name).CodeModule
With VBCodeMod
'ws.Cells(Zei, Spa + 2) = VBCodeMod.Name
For N = 1 To .CountOfLines
If IstProz(.Lines(N, 1)) "" Then ws.Cells(Zei, Spa + 2) = IstProz(.Lines(N, 1))
ws.Cells(Zei, Spa + 3) = .Lines(N, 1)
If InStr(.Lines(N, 1), "'") \> 0 Then
ws.Cells(Zei, Spa + 3).Characters(Start:=InStr(.Lines(N, 1), "'"), Length:=Len(.Lines(N, 1)) - InStr(.Lines(N, 1), "'") + 1).Font.ColorIndex = 5
End If
Call ZeileSpalte
Next N
End With
Next CMdl
ws.UsedRange.Columns.AutoFit
End Sub
Function ZeileSpalte()
Zei = Zei + 1
If Zei \> ThisWorkbook.Worksheets("Tabelle1").Rows.Count Then
Zei = 2
Spa = Spa + 4
End If
End Function
Function IstProz(ByVal Zeile As String)
Dim Vorh As Boolean, N As Byte, Woerter
Woerter = Array("Sub ", "Function ", "Property ")
For N = 0 To UBound(Woerter)
If InStr(Zeile, Woerter(N)) \> 0 Then
If InStr(Zeile, "'") = 0 Then
IstProz = Zeile
Else
If InStr(Zeile, "'") \> InStr(Zeile, ")") Then
IstProz = Left(Zeile, InStr(Zeile, "'") - 1)
End If
End If
Exit For
End If
Next N
End Function
Gruß
Reinhard
Sub ListProcedures(ByVal wb As Workbook)
'Verweis auf Microsoft Visual basic for Applications Extensibility muß gesetzt sein!!
'Code 2007 by Reinhard
Dim VBCodeMod As CodeModule, lngStartLine As Long, strMsg As String
Dim strModName As String, CMdl, Zeile As Long, Spalte As Integer
Dim N As Long, Von As Long, Bis As Long, Prozedur As String
Dim ws As Worksheet
Call ZeileSpalte
Set ws = ThisWorkbook.Worksheets("Tabelle1")
ws.Cells(Zei, Spa) = wb.Name
For Each CMdl In wb.VBProject.VBComponents
ws.Cells(Zei, Spa + 1) = CMdl.Name
Set VBCodeMod = wb.VBProject.VBComponents(CMdl.Name).CodeModule
With VBCodeMod
lngStartLine = .CountOfDeclarationLines + 1
Do Until lngStartLine \>= .CountOfLines
Prozedur = .ProcOfLine(lngStartLine, vbext\_pk\_Proc)
ws.Cells(Zei, Spa + 2) = Prozedur
For N = 1 To lngStartLine - 1
ws.Cells(Zei, Spa + 3) = .Lines(N, 1)
Call ZeileSpalte
Next N
On Error GoTo Weiter 'Fehler wenn Prozedur keine Sub oder Function sondern Property
lngStartLine = lngStartLine + .ProcCountLines(.ProcOfLine(lngStartLine, vbext\_pk\_Proc), vbext\_pk\_Proc)
On Error GoTo 0
Von = .ProcStartLine(Prozedur, vbext\_pk\_Proc)
Bis = .ProcCountLines(Prozedur, vbext\_pk\_Proc)
For N = Von To Von + Bis - 1
ws.Cells(Zei, Spa + 3) = .Lines(N, 1)
Call ZeileSpalte
Next N
Loop
End With
Weiter:
Next CMdl
ActiveSheet.UsedRange.Columns.AutoFit
End Sub
