Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1212to1216
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

PW geschützte Dateien listen, die Makro enthalten

PW geschützte Dateien listen, die Makro enthalten
Beffen
Guten Morgen, ihr Excellenten ^^
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
AW: PW geschützte Dateien listen, die Makro enthalten
08.05.2011 12:19:04
schauan
Hallo Beffen,
hier mal zwei Hinweise.
Ob generell ein Zugrif auf das VBA-Projekt erlaubt ist, brauchst Du nicht bei jeder Datei zu prüfen. Hier reicht ja schon, wenn Du in der Testmappe prüfst, ob der Zugriff möglich ist. Eventuell geht das dazu:
Sub VBETest()
'aktiveren des microsoft xml verweises
Dim VBEObj As Object
On Error GoTo Error
Set VBEObj = Application.VBE.ActiveVBProject.References
On Error Resume Next
VBEObj.AddFromFile "C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSXML5.DLL"
GoTo Skip1 'Code zur Fehlerbehandlung überspringen
Error:
MsgBox "Zur Bearbeitung dieser Datei müssen Sie Ihre Excel-Sicherheitseinstellungen anpassen.  _
Bitte gehen Sie wie folgt vor:" & vbCrLf & "Extras -> Makro -> Sicherheit -> Vertrauenswürdige Herausgeber -> Zugriff auf Visual Basic-Projekt aktiveren" & vbCrLf & "Danach bitte das Dokument erneut öffnen", vbCritical, "Hinweis"
ActiveWorkbook.Close False
Skip1:
End Sub
Ob eine Mappe passwortgeschützt ist, könntest Du eventuell feststellen, indem Du versuchst, per Formal oder excel4 oder ... einen Wert rauszuholen. Führt das zu einem Fehler, gibt es wohl den Schutz.
Gruß, André
Anzeige
AW: PW geschützte Dateien listen, die Makro enthalten
09.05.2011 08:58:49
Beffen
Guten Morgen, André.
Vielen Dank für deine Mühe.
Ja, das mit den Sicherheitseinstellungen ist auch so ein Problem. ABER: Das Makro kann nicht ausgeführt werden, wenn den Einstellungen nicht vertraut wird. Die Einstellungen sind hier aber schon entsprechend geändert.
Wie schon oben gesagt, geht es um die Dateien, die gescannt werden. Ist dort irgendwo ein "Passwortschutz beim Öffnen" gesetzt, hält das Makro an, da es nicht untersuchen kann, ob ein Makro drin ist, ohne die Datei zu öffen. Bei nem Klick auf "Abbrechen" fährt das Makro mit der nächsten Datei fort.
Da die Ausführung bei 400.000Dateien eine gewisse Zeit andauert, läft die Anwendung über mehrere Tage und Nächte. Nun kann nicht ständig jemand am Rechner stehen und auf "Abbrechen" klicken und in der Nacht ist keiner da. Schlimmstenfalls hält das Makro kurz nach Feierabend an und wartet dann die ganze Nacht auf eine Eingabe.... Deswegen meine Anfrage....
Hat jemand ne Idee?
Gruß Beffen
Anzeige
AW: PW geschützte Dateien listen, die Makro enthalten
09.05.2011 09:16:55
Tino
Hallo,
es gibt da einen Code (glaube von Nepumuk)
mit dem man prüfen kann ob eine Datei Schreibgeschützt ist, bevor man diese öffnet.
Option Explicit
Private Function IsFileProtect(strFilePath As String) As Boolean
    Dim intFreeFile As Integer
    Dim lngRowPosition As Long, lngPosBOF() As Long, lngCounter As Long
    Dim lngCountBOF As Long, lngFindBOF As Long, lngFindDBCell As Long
    Dim lngRecordLength As Long, lngFilePosition As Long
    Dim strRowString As String, strDBCellString As String, strBOFString As String
    Dim strBuffer As String
    Dim bytBuffer() As Byte
    On Error Resume Next
    Redim lngPosBOF(1 To 10)
    strBOFString = Chr$(9) & Chr$(8) & Chr$(16) & Chr$(0)
    strDBCellString = Chr$(&HD7) & Chr$(0)
    strRowString = Chr$(&H8) & Chr$(&H2) & Chr$(&H10)
    intFreeFile = FreeFile
    Open strFilePath For Binary Access Read As #intFreeFile
    strBuffer = String$(LOF(intFreeFile), 0)
    Get #intFreeFile, , strBuffer
    Close #intFreeFile
    lngFindBOF = InStr(1, strBuffer, strBOFString)
    Do While lngFindBOF
        lngCountBOF = lngCountBOF + 1
        If lngCountBOF > Ubound(lngPosBOF) Then _
            Redim Preserve lngPosBOF(1 To Ubound(lngPosBOF) + 10)
        lngPosBOF(lngCountBOF) = lngFindBOF
        lngFindBOF = InStr(lngFindBOF + 1, strBuffer, strBOFString)
    Loop
    Redim Preserve lngPosBOF(1 To lngCountBOF)
    Do
        lngFindDBCell = lngFindDBCell + 1
        lngFindDBCell = InStr(lngFindDBCell, strBuffer, strDBCellString)
        If lngFindDBCell = 0 Then Exit Do
        If lngFindDBCell > lngPosBOF(1) Then Exit Do
        bytBuffer = StrConv(Mid$(strBuffer, lngFindDBCell + 4, 2), vbFromUnicode)
        lngRowPosition = lngFindDBCell - FileDwToLong(bytBuffer(0), bytBuffer(1))
        If InStr(lngRowPosition, strBuffer, strRowString) = lngRowPosition Then
            Exit Do
        Else
            lngRowPosition = 0
        End If
    Loop
    For lngCounter = 1 To Ubound(lngPosBOF)
        bytBuffer = StrConv(Mid$(strBuffer, _
            lngPosBOF(lngCounter) + 6, 1), vbFromUnicode)
        If (bytBuffer(0) And 5) = 5 Then Exit For
    Next
    lngFilePosition = lngPosBOF(lngCounter)
    Do
        bytBuffer = StrConv(Mid$(strBuffer, lngFilePosition + 2, 2), vbFromUnicode)
        Err.Clear
        lngRecordLength = FileDwToLong(bytBuffer(0), bytBuffer(1)) + 5
        bytBuffer = StrConv(Mid$(strBuffer, lngFilePosition - 1, _
            lngRecordLength), vbFromUnicode)
        If Err.Number <> 0 Then Exit Do
        If (bytBuffer(1) = 0) And (bytBuffer(2) = 0) Then Exit Do
        If (bytBuffer(1) = 255) And (bytBuffer(2) = 255) Then Exit Do
        If bytBuffer(1) = &H13 Then
            IsFileProtect = GetTextFromRecord(bytBuffer) <> "00"
            Exit Function
        End If
        lngFilePosition = lngFilePosition + lngRecordLength - 1
        If bytBuffer(1) = &HA Then
            lngCounter = lngCounter + 1
            If lngCounter > Ubound(lngPosBOF) Then Exit Do
            lngFilePosition = lngPosBOF(lngCounter)
        End If
    Loop
End Function

Private Function FileDwToLong(ByVal ByteLeft As Byte, ByVal ByteRight As Byte) As Long
    FileDwToLong = CLng(ByteRight) * CLng(256) + CLng(ByteLeft)
End Function

Private Function GetTextFromRecord(bytRecord() As Byte) As String
    Dim lngCounter As Long, lngEnd As Long, lngRecordLength As Long
    lngRecordLength = FileDwToLong(bytRecord(3), bytRecord(4))
    If lngRecordLength = 0 Then Exit Function
    If lngRecordLength = 2 Then
        GetTextFromRecord = Hex$(bytRecord(5)) & Hex$(bytRecord(6))
        Exit Function
    Else
        lngEnd = FileDwToLong(bytRecord(5), bytRecord(6)) + 7
        For lngCounter = 8 To lngEnd
            GetTextFromRecord = GetTextFromRecord & Chr$(bytRecord(lngCounter))
        Next
    End If
End Function


Public Sub BeispielVerwendung()
    
    If IsFileProtect("J:\Ordner\Beispiel.xls") Then
     MsgBox "Datei ist geschützt"
    Else
     MsgBox "Datei ist nicht geschützt"
    End If

End Sub
Gruß Tino
Anzeige
AW: PW geschützte Dateien listen, die Makro enthalten
09.05.2011 10:53:08
Beffen
Hallo Tino,
Schreib- und Passwortgeschützt ist doch aber nicht dasselbe?!
Gruß Beffen
Probiere es doch einfach aus oT.
09.05.2011 11:06:55
Tino
AW: Probiere es doch einfach aus oT.
09.05.2011 20:41:41
schauan
Hallo Beffen,
wie ich schon schrieb, den Schutz beim Öffnen bekommst Du schon mit, wenn Du keine Werte aus der Datei ziehen kannst. Suche mal nach Excel Daten aus geschlossener Mappe, da findest Du u.a. Beispiele mit einem Excel4Macro. Das läuft bei einer Passwortgeschützten Datei auf einen Fehler, den man abfangen kann.
Gruß. André
AW: PW geschützte Dateien listen, die Makro enthalten
10.05.2011 10:27:06
Tino
Hallo,
hier ein Beispiel, die Dateien die nicht Passwortgeschützt sind, werden geöffnet.
Die Dateien die nur ein Schreibschutzkennwort werden auch geöffnet.
https://www.herber.de/bbs/user/74751.zip
Gruß Tino
Anzeige
Tausend Dank (o.w.T.)
10.05.2011 12:33:11
Beffen
Hallo Tino, ich danke Dir tausendmal!
Es scheint zu funktionieren. Genau diesen Codeschnipsel hab ich gesucht!!!!
Danke nochmal.
Gruß Beffen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige