4
Finden von Office-Dateien mit Schreibschutz
Hallo!
Gibt es eine Möglichkeit, automatisiert bzw. mit sehr wenig Aufwand Office-Dateien zu suchen, die durch einen Schreibschutz geschützt sind???
Bin um jede Hilfe dankbar!
Danke,
kerstine
Gibt es eine Möglichkeit, automatisiert bzw. mit sehr wenig Aufwand Office-Dateien zu suchen, die durch einen Schreibschutz geschützt sind???
Bin um jede Hilfe dankbar!
Danke,
kerstine
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 4084
Url: https://administrator.de/contentid/4084
Printed on: April 23, 2024 at 11:04 o'clock
4 Comments
Latest comment
Hallo,
vielleicht hilft dir das einwenig.
In der Variablen strExt stehen kommagetrennt die Dateiendungen.
Das Script durchsucht rekursiv alle Ordner unter dem in der InputBox angegebenen und gibt das Ergebnis mit Pfad in einer Datei aus.
~~~~~~~~~~~~~~~~~
Option Explicit
Dim objFSO, objFolder, objSubFld, objLog, f1, f2, colFiles, strExt, strMSG, arExt, strStart, i
strExt = "xls,doc,mdb,pps"
strMSG = "Schreibgeschützte Dateien"
strStart = InputBox("Wo solls denn losgehen?","Check4ReadOnly")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strStart)
ChkSubFld objFolder
Private Sub ChkSubFld(StartFolder)
ChkFiles StartFolder
Set objSubFld = StartFolder.SubFolders
For Each f2 in objSubFld
ChkSubFld f2
Next
End Sub
Private Sub ChkFiles(Start)
Set colFiles = Start.Files
For Each f1 in colFiles
arExt = Split(strExt, ",", -1, 1)
For i = 0 To UBound(arExt)
If LCase(Right(f1, 3)) = arExt(i) Then
If f1.Attributes AND 1 Then
strMSG = strMSG & vbCrLf & objFSO.GetAbsolutePathName(f1)
End If
End If
Next
Next
End Sub
Set objLog = objFSO.CreateTextFile("c:\CheckReadOnly.txt", True)
objLog.Write strMSG
objLog.Close
f1 = ""
f2 = ""
i = ""
strExt = ""
strMSG = ""
strStart = ""
colFiles = ""
~~~~~~~~~~~~~~~~~
vielleicht hilft dir das einwenig.
In der Variablen strExt stehen kommagetrennt die Dateiendungen.
Das Script durchsucht rekursiv alle Ordner unter dem in der InputBox angegebenen und gibt das Ergebnis mit Pfad in einer Datei aus.
~~~~~~~~~~~~~~~~~
Option Explicit
Dim objFSO, objFolder, objSubFld, objLog, f1, f2, colFiles, strExt, strMSG, arExt, strStart, i
strExt = "xls,doc,mdb,pps"
strMSG = "Schreibgeschützte Dateien"
strStart = InputBox("Wo solls denn losgehen?","Check4ReadOnly")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strStart)
ChkSubFld objFolder
Private Sub ChkSubFld(StartFolder)
ChkFiles StartFolder
Set objSubFld = StartFolder.SubFolders
For Each f2 in objSubFld
ChkSubFld f2
Next
End Sub
Private Sub ChkFiles(Start)
Set colFiles = Start.Files
For Each f1 in colFiles
arExt = Split(strExt, ",", -1, 1)
For i = 0 To UBound(arExt)
If LCase(Right(f1, 3)) = arExt(i) Then
If f1.Attributes AND 1 Then
strMSG = strMSG & vbCrLf & objFSO.GetAbsolutePathName(f1)
End If
End If
Next
Next
End Sub
Set objLog = objFSO.CreateTextFile("c:\CheckReadOnly.txt", True)
objLog.Write strMSG
objLog.Close
f1 = ""
f2 = ""
i = ""
strExt = ""
strMSG = ""
strStart = ""
colFiles = ""
~~~~~~~~~~~~~~~~~
Hi!
Danke für den Tip - ich bekomm leider immer den fehler
Zeile 23, Zeichen 1
Zugriff verweigert...
Danke für den Tip - ich bekomm leider immer den fehler
Zeile 23, Zeichen 1
Zugriff verweigert...
Guten Morgen!
Ich hätte vielleicht noch dazuschreiben sollen, dass ich es nicht getestet habe.
Ist auch nicht sehr ausgefeilt, nur eben schnell hingeklopft.
War ja auch schon spät gestern.
In Ordnern die keine speziellen Unterordner (wie bspw. System Volume Information) haben sollte es schon laufen.
Ich seh es mir heute abend mal an.
Ich hätte vielleicht noch dazuschreiben sollen, dass ich es nicht getestet habe.
Ist auch nicht sehr ausgefeilt, nur eben schnell hingeklopft.
War ja auch schon spät gestern.
In Ordnern die keine speziellen Unterordner (wie bspw. System Volume Information) haben sollte es schon laufen.
Ich seh es mir heute abend mal an.
Hallo Kerstin,
Zugriff verweigert = Du kommst hier net rein
Im Ernst, der Fehler tritt auf, wenn f2 in der Ordnerauflistung auf einen Ordner trifft für den die Rechte nicht ausreichen. Normalerweise haben User in solchen Ordnern nichts zu suchen und erst recht nichts zu speichern.
Um mir mein Wochenende zu retten hab ich mirs einfach gemacht.
Diese Fehler führen jetzt nicht mehr zum Abbruch (Resume Next).
~~~~~~~~~~~~~~~~~~~~
Option Explicit
On Error Resume Next
Dim objFSO, objFolder, objSubFld, objLog, f1, f2, colFiles, strExt, strMSG, arExt, strStart, strLog, i
strExt = "xls,doc,mdb,pps"
strStart = InputBox("Wo solls denn losgehen?","Check4ReadOnly")
strMSG = "Schreibgeschützte Dateien von " & strStart & " beginnend" & vbCrLf & "~~~~~~~~~~~~~~~~~~~~~~~~~~~"
strLog = "c:\CheckReadOnly.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strStart)
ChkSubFld objFolder
Private Sub ChkSubFld(StartFolder)
ChkFiles StartFolder
Set objSubFld = StartFolder.SubFolders
For Each f2 in objSubFld
ChkSubFld f2
Next
End Sub
Private Sub ChkFiles(Start)
Set colFiles = Start.Files
For Each f1 in colFiles
arExt = Split(LCase(strExt), ",", -1, 1)
For i = 0 To UBound(arExt)
If LCase(Right(f1, 3)) = arExt(i) Then
If f1.Attributes AND 1 Then
strMSG = strMSG & vbCrLf & objFSO.GetAbsolutePathName(f1)
End If
End If
Next
Next
End Sub
Set objLog = objFSO.CreateTextFile(strLog, True)
objLog.Write strMSG
objLog.Close
MsgBox "Fertig!"
LoadFile strLog
Private Sub LoadFile(File)
Dim objShell, strApplication
strApplication = "notepad.exe"
Set objShell = CreateObject("WScript.Shell")
objShell.Run strApplication & " " & File
set objShell = Nothing
End Sub
Set objFSO = Nothing
Set objFolder = Nothing
Set objLog = Nothing
f1 = ""
f2 = ""
i = ""
strExt = ""
strMSG = ""
strStart = ""
colFiles = ""
strLog = ""
strApp = ""
arExt = ""
~~~~~~~~~~~~~~~~~~~~
Schönes Wochenende
Zugriff verweigert = Du kommst hier net rein
Im Ernst, der Fehler tritt auf, wenn f2 in der Ordnerauflistung auf einen Ordner trifft für den die Rechte nicht ausreichen. Normalerweise haben User in solchen Ordnern nichts zu suchen und erst recht nichts zu speichern.
Um mir mein Wochenende zu retten
hab ich mirs einfach gemacht.Diese Fehler führen jetzt nicht mehr zum Abbruch (Resume Next).
~~~~~~~~~~~~~~~~~~~~
Option Explicit
On Error Resume Next
Dim objFSO, objFolder, objSubFld, objLog, f1, f2, colFiles, strExt, strMSG, arExt, strStart, strLog, i
strExt = "xls,doc,mdb,pps"
strStart = InputBox("Wo solls denn losgehen?","Check4ReadOnly")
strMSG = "Schreibgeschützte Dateien von " & strStart & " beginnend" & vbCrLf & "~~~~~~~~~~~~~~~~~~~~~~~~~~~"
strLog = "c:\CheckReadOnly.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strStart)
ChkSubFld objFolder
Private Sub ChkSubFld(StartFolder)
ChkFiles StartFolder
Set objSubFld = StartFolder.SubFolders
For Each f2 in objSubFld
ChkSubFld f2
Next
End Sub
Private Sub ChkFiles(Start)
Set colFiles = Start.Files
For Each f1 in colFiles
arExt = Split(LCase(strExt), ",", -1, 1)
For i = 0 To UBound(arExt)
If LCase(Right(f1, 3)) = arExt(i) Then
If f1.Attributes AND 1 Then
strMSG = strMSG & vbCrLf & objFSO.GetAbsolutePathName(f1)
End If
End If
Next
Next
End Sub
Set objLog = objFSO.CreateTextFile(strLog, True)
objLog.Write strMSG
objLog.Close
MsgBox "Fertig!"
LoadFile strLog
Private Sub LoadFile(File)
Dim objShell, strApplication
strApplication = "notepad.exe"
Set objShell = CreateObject("WScript.Shell")
objShell.Run strApplication & " " & File
set objShell = Nothing
End Sub
Set objFSO = Nothing
Set objFolder = Nothing
Set objLog = Nothing
f1 = ""
f2 = ""
i = ""
strExt = ""
strMSG = ""
strStart = ""
colFiles = ""
strLog = ""
strApp = ""
arExt = ""
~~~~~~~~~~~~~~~~~~~~
Schönes Wochenende
