Makros , Prozeduren auflisten
Was ich bisher nicht fertig gebracht habe, ist, die
Makro namen in den einzelnen Moduln auszulesen. Ich
sende euch nun meinen heutigen Stand, mit der Bitte, die Zeile
mit den „???“ zu editieren.
Hallo Erich,
sorry, habe mir jetzt den Code nicht näher angesehen, weil, ich
glaube ich habe was besseres erschaffen.
Warnung:
Vor Austestung des nachfolgenden Codes, sollte man seine excel.xlb
sichern. Wenn man in den Symbolleisten nie was geändert hat, braucht
man das nicht, dann löscht man einfach excel.xlb und fertig, Excel
legt beim Start dann eine neue mit den Standardeinstellungen an, kein
Problem.
Hintergrund ist, ich habe in einem Verzeichnis eine
Datei „findlinks.xlS“. Das ist zwar eine xlS, aber irgendwie auch
eine xlA, habe das noch nicht ganz kapiert.
Jedenfalls verabschiedete sich Excel grußlos als es diese Datei
öffnen sollte. Aus dem Grund ist im Code die Fehlerroutine drinnen,
die dann solche Dateien am Ende der Tabelle auflistet, wo es diese
Problematik gibt.
(Wer sich mit dem Code beschäftigen will, normalerweise ist nach
Workbook.open die neue Mappe das Achtiveworkbook, bei findlink.xls
war das völlig anders, da war, weil das Öffnen nicht korrekt
funktionierte o.ä. die Mappe die die Codes enthielt das
Activeworkbook, was dann logischerweise schlecht kam bei wb.close
*gg*. Deshalb an der dortigen Stelle im Code nochmals die
Namensüberprüfung bevor eine Mappe geschlossen wird.)
Warum man seine excel.xlb sichern soll? Nun, nach vielen
Codetestungen hatte ich in der Symbolleiste, weiß gar nicht mehr
unter welchen Menuepunkt, 50mal die Eintragung „findlink“.
Nur deshalb die Warnung.
Getestet auf XL2000.
Neue Features:
Die Dateinamen werden als Hyperlink eingetragen, so daß man sie
bequem öffnen kann.
Die geschätzte Restzeit bis der Code fertig ist wird in der
Statuszeile angezeigt.
Dateien mit denen es beherrschbare Probleme gab werden am Ende der
Tabelle aufgelistet und der Code springt bei Programmende dann dahin.
Sollten unlösbare Probleme auftreten so wird die Datei genannt mit
der es diese gab.
Code für Modul1 :
Option Explicit
Public Zei As Long, Spa As Integer
Sub MappenOeffnen()
'Öffnet alle Dateien im Ordner "Pfad" und listet alle Prozeduren auf.
'2007 by Reinhard
Dim wb, Pfad As String, fs As FileSearch, N As Long, ws As Worksheet
Dim oldStatusBar, Anz As Long, ProblemDateien() As Variant, PD As Long
Dim AllesOK As Boolean, Meldung As String, PfadDatei As String
Dim PfadDateiNr As Long, Gefunden As Long, Zeit As Double, Von As Double
Dim Schnitt As Double, Restzeit As Double, Restmin As Byte, Restsek As Byte
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
'On Error GoTo Fehler
'Pfad = "C:\Download"
'Pfad = ThisWorkbook.Path
Pfad = "C:\Download"
Set ws = ThisWorkbook.Worksheets("Tabelle1")
Set fs = Application.FileSearch
Call MappenSchliessen
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Zei = 1
Spa = 1
With ws
.Cells.Clear
.Hyperlinks.Delete
.Cells.Font.ColorIndex = xlAutomatic
.[A2:smiley:2] = Split("Mappe Modul Prozedur Code")
.[A2:smiley:2].Copy Destination:=.[E2:IV2]
.[A1] = "Pfad: " & Pfad
.[A1].Font.Bold = True
End With
ActiveWindow.FreezePanes = False
With fs
.LookIn = Pfad
.Filename = "\*.xls"
.SearchSubFolders = True
.Execute
Gefunden = .FoundFiles.Count
Restzeit = .FoundFiles.Count \* 2
Restmin = Int(Restzeit / 60)
Restsek = Restzeit - 60 \* Restmin
For N = 1 To .FoundFiles.Count
Von = Timer
If InStr(.FoundFiles(N), "\Personl.xls") = 0 And InStr(.FoundFiles(N), "\" & ThisWorkbook.Name) = 0 Then
PfadDatei = .FoundFiles(N)
PfadDateiNr = N
Workbooks.Open .FoundFiles(N), 0, True
Set wb = ActiveWorkbook
If UCase(wb.Name) "PERSONL.XLS" And wb.Name ThisWorkbook.Name Then
Meldung = "Bearbeite gerade " & N & " / " & .FoundFiles.Count & " Dateien."
Meldung = Meldung & " Geschätze Restzeit: " & Restmin & " Minuten und "
Meldung = Meldung & Restsek & " Sekunden."
Application.StatusBar = Meldung
Call ListProcedures2(wb)
If wb.Name ThisWorkbook.Name Then wb.Close savechanges:=False
Else
Anz = Anz + 1
ReDim Preserve ProblemDateien(Anz)
ProblemDateien(Anz) = .FoundFiles(N)
End If
End If
Zeit = Zeit + Timer - Von
Schnitt = Zeit / N
If Int(Schnitt \* (.FoundFiles.Count - N)) 0 Then
Call ZeileSpalte
ws.Cells(Zei, Spa) = "Probleme gab es mit:"
For PD = 1 To Anz
Call ZeileSpalte
ws.Hyperlinks.Add Anchor:=ws.Cells(Zei, Spa), Address:=ProblemDateien(PD), ScreenTip:=ProblemDateien(PD), TextToDisplay:=Mid(ProblemDateien(PD), InStrRev(ProblemDateien(PD), "\") + 1)
'ws.Cells(Zei, Spa) = ProblemDateien(PD)
Next PD
End If
ws.Range("A1").Select
Fehler:
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
'ws.[A3].Select
If AllesOK = True Then
If Anz = 0 Then
MsgBox "Die Prozeduren von " & Gefunden & " Dateien wurden problemlos aufgelistet."
Else
MsgBox "Es wurden die Prozeduren von " & Gefunden - Anz & " der " & Gefunden & " Dateien aufglistet."
ws.Cells(Zei, Spa).Select
End If
Else
MsgBox "Es gibt ein unlösbares Problem mit der Datei " & PfadDatei & Chr(13) \_
& "Es ist die Datei " & PfadDateiNr & " / " & Gefunden
End If
End Sub
Sub MappenSchliessen()
Dim wb As Workbook
For Each wb In Workbooks
If UCase(wb.Name) "PERSONL.XLS" And wb.Name ThisWorkbook.Name Then
wb.Close savechanges:=False
End If
Next wb
End Sub
Sub ListProcedures2(ByVal wb As Workbook)
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, Meldung As String
Call ZeileSpalte
Set ws = ThisWorkbook.Worksheets("Tabelle1")
On Error Resume Next
ws.Hyperlinks.Add Anchor:=ws.Cells(Zei, Spa), Address:=wb.FullName, ScreenTip:=Mldg(wb), TextToDisplay:=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
'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
Function Mldg(ByVal wb As Workbook) As String
Mldg = wb.FullName & Chr(10) & Chr(10)
Mldg = Mldg & "Erstellt von: " & wb.BuiltinDocumentProperties("Author") & Chr(10)
Mldg = Mldg & "Erstellt am: " & wb.BuiltinDocumentProperties("Creation date") & Chr(10)
Mldg = Mldg & "Zuletzt benutzt von: " & wb.BuiltinDocumentProperties("Last author") & Chr(10)
Mldg = Mldg & "Zuletzt benutzt am: " & wb.BuiltinDocumentProperties("Last save time") & Chr(10)
Mldg = Mldg & "Dateigröße: " & FileLen(wb.FullName) & " Bytes."
End Function
Gruß
Reinhard
