ich hab schon hier im Forum riesen Hilfe bei der Entwicklung eines Makros enthalten, welches ein gewähltes Verzeichnis scannt und alle Excel, Word und Access-Dateien listet und nach dem Vorhandensein von Makros scannt und entsprechend auflistet.
Nun bleibt das Programm bei Dateien, die Passwörter erfordern aber konsequent stehen und beharrt auf die Passworteingabe. Wird auf "Abbrechen" geklickt (weil das Passwort keiner mehr weiss), fährt das Makro fort. ausserdem gibt es noch andere Fehlermeldungen, wie zu strenge Registrierungsrichtlinieneinstellungen, die den Zugriff blockieren.
Gibt es eine Möglichkeit, wenn das Makro seit 10 Sekunden auf das Öffnen einer Datei warten muss, das Öffnen abzubrechen und mit der nächsten fortzusetzen? und als Ergebnis in der Auflistung dann "Fehler" oder sowas einzutragen? Sozusagen als nachweis, dass die Datei gefunden, aber nicht geöffnet wurde?
Vielen Dank.
Anbei der anonymisierte bisherige Code: (Dank an FCS und andere!!!)
Option Explicit
Sub GetMakroList()
Dim FSO As Object, oFolder As Object
Dim strFolder As String
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)
With ThisWorkbook.Sheets(1)
.Cells.Clear
.Cells(1, 1) = "Dateiname"
.Cells(1, 2) = "Modulname"
.Cells(1, 3) = "Prozedurname"
End With
With Application
.DisplayAlerts = False 'Warnmeldungen deaktiviert
.EnableEvents = False 'Hinweisfenster deaktiviert
.ScreenUpdating = False 'Bildschirmupdate deaktiviert - Beschleunigung des Vorganges
End With
prcFiles oFolder
prcSubFolders oFolder
ThisWorkbook.Sheets(1).Columns.AutoFit 'Spalten Autob-Einpassen
With Application
.DisplayAlerts = True 'Warnmeldungen aktiviert
.EnableEvents = True 'Hinweisfenster aktiviert
.ScreenUpdating = True 'Bildschirmupdate aktiviert
End With
End Sub
Private Sub prcFiles(oFolder)
Dim oFile As Object, wkb As Object, appWd As Object
On Error Resume Next
For Each oFile In oFolder.Files
Select Case LCase(Right(oFile, 4))
Case ".xls", ".xlt", "xlsx", "xlsm", "xltx", "xlsb" 'Endungen, die _
Excel-Applikation provozieren
Set wkb = Workbooks.Open(Filename:=oFile.Path, UpdateLinks:=False, _
ReadOnly:=True) 'Aktualisieren _
von Verknüpfungen deaktiviert, Schreibegeschützte Kopie öffnen
Case ".doc", ".dot", "docx", "docm", "dotx", "dotm" 'Endungen, die _
Word-Applikation provozieren
Set appWd = CreateObject("Word.Application")
appWd.Visible = True 'Word- _
Applikation anzeigen
Set wkb = appWd.documents.Open(Filename:=oFile.Path, ReadOnly:=True) 'Schreibgeschü _
tzte Kopie öffnen
Case ".mdb" 'Endungen, die _
Access-Applikation öffnen - ungetestet!!
MakroListeMdb oFile.Path
End Select
If Not wkb Is Nothing Then
MakroListe wkb
wkb.Close False
Set wkb = Nothing
If Not appWd Is Nothing Then appWd.Quit 'Word-Applikation beenden - sonst GEFAHR: _
Scheinanwendungen überlasten System!
Set appWd = Nothing
End If
Next
End Sub
Private Sub prcSubFolders(oFolder) 'Initiieren der Suche in Unterordnern
Dim oSubFolder As Object
On Error Resume Next
For Each oSubFolder In oFolder.SubFolders
prcFiles oSubFolder
prcSubFolders oSubFolder
Next
End Sub
Sub MakroListe(wkb As Object)Dim vbc As Object, wks As Worksheet
Dim iRow As Integer, iCounter As Integer
Dim sName As String
Set wks = ThisWorkbook.Sheets(1)
iCounter = wks.Cells(wks.Rows.Count, 3).End(xlUp).Row + 1
For Each vbc In wkb.VBProject.VBComponents
iRow = 1
With vbc.CodeModule
Do While iRow If .ProcOfLine(iRow, 0) "" And .ProcOfLine(iRow, 0) sName Then
sName = .ProcOfLine(iRow, 0)
wks.Cells(iCounter, 1) = wkb.FullName
wks.Cells(iCounter, 2) = vbc.Name
wks.Cells(iCounter, 3) = sName
iCounter = iCounter + 1
iRow = .ProcStartLine(sName, 0) + .ProcCountLines(sName, 0) - 1
End If
iRow = iRow + 1
Loop
End With
iRow = 0
Next vbc
If wks.Cells(iCounter - 1, 1) wkb.FullName Then
wks.Cells(iCounter, 1) = wkb.FullName
wks.Cells(iCounter, 3) = "Keine Prozedur-Code-Zeilen"
End If
End Sub Sub MakroListeMdb(pfad As String)
Dim appAC As Object, wks As Worksheet
Dim iRow As Integer, iCounter As Integer
Dim i As Integer, j As Integer
Dim sName As String
Set wks = ThisWorkbook.Sheets(1)
iCounter = wks.Cells(wks.Rows.Count, 3).End(xlUp).Row + 1
Set appAC = CreateObject("Access.Application")
appAC.Visible = True
appAC.OpenCurrentDatabase pfad
For i = 0 To appAC.Modules.Count - 1
For j = 1 To appAC.Modules(i).CountOfLines
sName = appAC.Modules(i).ProcOfLine(j, 0)
If sName appAC.Modules(i).ProcOfLine(j + 1, 0) Then
wks.Cells(iCounter, 1) = pfad
wks.Cells(iCounter, 2) = appAC.Modules(i).Name
wks.Cells(iCounter, 3) = appAC.Modules(i).ProcOfLine(j + 1, 0)
iCounter = iCounter + 1
End If
Next
Next
If wks.Cells(iCounter - 1, 1) pfad Then
wks.Cells(iCounter, 1) = pfad
wks.Cells(iCounter, 3) = "Keine Prozedur-Code-Zeilen"
End If
appAC.CloseCurrentDatabase
appAC.Quit 'Access-Anwendungsobjekt beenden
Set appAC = Nothing
End Sub