Hallo zusammen,
Ich hab zur einheitlichen Dokumentenbereitstellung eine Datei erstellt, welche automatisch vorab definierte Eigenschaften sämtlicher Dateien in einem Verzeichnis ausliest und diese für weitere Schritte bereitstellt.
Den Basis-Code hab ich vor einiger Zeit bei Recherchen im Netz gefunden.
Nachdem das ganze Konstrukt auf meinem Rechner fehlerfrei läuft und ich damit nun auch schon eine Weile arbeite, hab ich die ersten Testläufe bei ein paar Kollegen vorgenommen.
Alles läuft einwandfrei, aber ein einzelner Rechner zickt rum.
Im Gegensatz zu allen anderen vorab durchgeführten Testläufen, läuft hier der Code zwar ebenfalls fehlerfrei durch, jedoch werden hier die falschen Dateieigenschaften ausgelesen.
Alle Rechner laufen mit Windows 10, Office 365, Excel 365.
Hier der Code:
Spoiler anzeigen
Hat jemand eine Ahnung, was hier das Problem an dem einem Rechner verursacht / verursachen könnte?
Besten Dank im Voraus für Eure Unterstützung
Spoiler hinzugefügt ~VaporiZed
Ich hab zur einheitlichen Dokumentenbereitstellung eine Datei erstellt, welche automatisch vorab definierte Eigenschaften sämtlicher Dateien in einem Verzeichnis ausliest und diese für weitere Schritte bereitstellt.
Den Basis-Code hab ich vor einiger Zeit bei Recherchen im Netz gefunden.
Nachdem das ganze Konstrukt auf meinem Rechner fehlerfrei läuft und ich damit nun auch schon eine Weile arbeite, hab ich die ersten Testläufe bei ein paar Kollegen vorgenommen.
Alles läuft einwandfrei, aber ein einzelner Rechner zickt rum.
Im Gegensatz zu allen anderen vorab durchgeführten Testläufen, läuft hier der Code zwar ebenfalls fehlerfrei durch, jedoch werden hier die falschen Dateieigenschaften ausgelesen.
Alle Rechner laufen mit Windows 10, Office 365, Excel 365.
Hier der Code:
Visual Basic-Quellcode
- Option Explicit
- Public glngFolder As Long, garrFolders() As Variant
- Sub Dateeigenschaften_gezielt()
- 'Stufe 1
- 'Einlesen der (Unter-)Ordner, Dateitypen (#164), Pfade (#194) und evtl. Verlinkungen (#203)
- Call Dateieigenschaften("P:\qm\_Management-Dokumentation\Ablage\", _
- varEigenschaften:=Array(164, 194, 203), NrIndex:=False)
- End Sub
- Private Sub Dateieigenschaften _
- (ByVal STRFOLDER As Variant, _
- Optional varEigenschaften As Variant, _
- Optional NrIndex As Boolean = False, _
- Optional bolUnterOrdner As Boolean = True)
- 'STRFOLDER: Ordner in dem die Eigenschaften der Dateien ausgelesen werden sollen
- 'varEigenschaften: Array mit den Index-Nummern der Eigenschaften, die ausgelesen werden sollen
- 'wird der parameter weggelassen, werden alle Eigenschaften ausgelesen
- 'NrIndex: optional, wenn True, dann werden in Zeile 1 die Index-Nrn der Eigenschaften ausgegeben
- 'bolUnterOrdner:optional, wenn True, dann wird in Spalte A das Unterverzeichnis der Datei ausgegeben
- Dim objShell As Object
- Dim objFolder As Object
- Dim x As Byte
- Dim intColumn As Integer
- Dim lngRow As Long
- Dim varName, arrHeaders(255)
- Dim varWert
- Dim wksAusgabe As Worksheet
- 'Statusbar einblenden
- Application.ScreenUpdating = True
- Application.DisplayStatusBar = True
- 'Abfrage, ob aktualisiert werden soll
- If MsgBox("Soll die Übersicht aktualisert werden?" & Chr(13) & Chr(13) & _
- "(das kann u.U. etwas dauern)", vbYesNoCancel) = vbYes Then
- GoTo SPRUNG1
- Else
- If MsgBox("ACHTUNG!" & Chr(13) & Chr(13) & _
- "Sie haben der Aktualisierung nicht zugestimmt." & Chr(13) & _
- "Es besteht somit die Gefahr, dass Sie mit einem veraltetem Stand arbeiten und somit nicht alle relevanten Daten angezeigt bekommen." & Chr(13) & Chr(13) & _
- "Möchten Sie die Übersicht doch noch aktualisieren?", vbYesNoCancel) = vbYes Then
- GoTo SPRUNG1
- Else
- MsgBox "Aktualisierung wurde abgebrochen."
- Exit Sub
- End If
- End If
- SPRUNG1:
- 'Prüfen, ob Ablage vorhanden
- If Dir(STRFOLDER, 16) = "" Then
- MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
- Exit Sub
- End If
- 'Tabelle entsperren
- Tabelle1.Unprotect
- 'Tabelle leeren
- Dim letzteZeile As Integer
- letzteZeile = Tabelle1.Cells(Rows.Count, 6).End(xlUp).Row
- Tabelle1.Range("B21:P" & letzteZeile).ClearContents
- 'Ordnerliste zurücksetzen
- glngFolder = 0
- Erase garrFolders
- 'Anzeige Statusbar einstellen
- Application.StatusBar = "Ordner im Verzeichnis """ & STRFOLDER & """ werden eingelesen"
- 'Makro für Unterordner aufrufen
- Call ListFoldersInFolder(SourceFolderName:=STRFOLDER)
- Set objShell = CreateObject("Shell.Application")
- 'Start Einlesen
- For glngFolder = 1 To UBound(garrFolders)
- 'Anzeige in Statusbar
- Application.StatusBar = "Schritt 1 von 3 >>> Dateien im Verzeichnis """ & _
- garrFolders(glngFolder) & """ werden eingelesen (Ordner " & glngFolder & _
- " von " & UBound(garrFolders) & " )"
- 'Bildschirmaktualisierung ausschalten
- With Application
- .ScreenUpdating = False
- .Calculation = xlCalculationManual
- .EnableEvents = False
- End With
- Set objFolder = objShell.Namespace(garrFolders(glngFolder))
- If glngFolder = 1 Then
- 'On Error Resume Next
- Set wksAusgabe = Tabelle1
- intColumn = 1
- 'Unterverzeichnis angeben
- If bolUnterOrdner = True Then
- intColumn = intColumn + 1
- With wksAusgabe
- If NrIndex = True Then
- .Cells(2, intColumn) = "Unterverzeichnis"
- Else
- .Cells(1, intColumn) = "Unterverzeichnis"
- End If
- End With
- End If
- 'Index-Nummer und Namen der Dateieigenschaften
- For x = 0 To 254
- If fncCheck(IIf(VBA.IsMissing(varEigenschaften), -1, x), varEigenschaften) Then
- intColumn = intColumn + 1
- arrHeaders(x) = objFolder.GetDetailsOf(varName, x)
- With wksAusgabe
- If NrIndex = True Then
- .Cells(19, intColumn) = x
- .Cells(20, intColumn) = arrHeaders(x)
- Else
- .Cells(20, intColumn) = arrHeaders(x)
- End If
- End With
- End If
- Next
- 'Anfang Auflistung
- If NrIndex = True Then
- wksAusgabe.Rows(20).Font.Bold = True
- lngRow = 21 'Start der Detail-Auflistung
- Else
- wksAusgabe.Rows(20).Font.Bold = True
- lngRow = 21 'Start der Detail-Auflistung
- End If
- End If
- 'Details auflisten
- For Each varName In objFolder.Items
- Select Case LCase(objFolder.GetDetailsOf(varName, 2))
- Case "dateiordner", "folder", "filefolder"
- 'Ordner in Dateiliste nicht ausgeben
- Case Else
- intColumn = 1
- 'Unterordner auflisten
- If bolUnterOrdner = True Then
- intColumn = intColumn + 1
- wksAusgabe.Cells(lngRow, intColumn) = "'" & Mid(garrFolders(glngFolder), Len(STRFOLDER) + 1)
- End If
- For x = 0 To 254
- 'Eigenschaften
- If fncCheck(IIf(IsMissing(varEigenschaften), -1, x), varEigenschaften) Then
- intColumn = intColumn + 1
- varWert = ""
- varWert = objFolder.GetDetailsOf(varName, x)
- Select Case x
- Case 3, 4, 5, 152, 153, 154 'Datum Zeit
- If IsDate(varWert) Then varWert = CDate(varWert)
- Case 12 'Aufnahmedatum (enthält sonderzeichen deshalb keine echtes Exceldatum
- If IsDate(varWert) Then
- varWert = CDate(varWert)
- End If
- Case Else
- varWert = "'" & varWert
- End Select
- wksAusgabe.Cells(lngRow, intColumn) = varWert
- End If
- Next
- lngRow = lngRow + 1
- End Select
- Next
- Next glngFolder
- 'Bildschirmaktualisierung einschalten
- With Application
- .ScreenUpdating = True
- .Calculation = xlCalculationAutomatic
- .EnableEvents = True
- End With
- 'Info-Box
- MsgBox "Übersicht wurde aktualisiert"
- 'Ordnerliste zurücksetzen
- glngFolder = 0
- Erase garrFolders
- 'Statusleiste zurücksetzen
- Application.StatusBar = False
- 'Tabelle sperren
- Tabelle1.Range("A1").Select
- Tabelle1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
- End Sub
- Private Function fncCheck(ByVal x As Integer, Optional varWerte) As Boolean
- Dim intJ As Integer
- fncCheck = False
- If x < 0 Then 'alle Eigenschaften
- fncCheck = True
- Else
- For intJ = LBound(varWerte) To UBound(varWerte)
- If x = varWerte(intJ) Then
- fncCheck = True
- Exit For
- End If
- Next
- End If
- End Function
- Private Sub ListFoldersInFolder(ByVal SourceFolderName As String)
- 'Makro erstellt zum Ordner-Namen ein Daten-Array mit den Namen der Ordner im Verzeichnis inkl. Unterverzeichnissen
- Dim FSO As Object, SourceFolder As Object, SubFolder As Object
- Set FSO = CreateObject("Scripting.FileSystemObject")
- Set SourceFolder = FSO.GetFolder(SourceFolderName)
- On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
- glngFolder = glngFolder + 1
- ReDim Preserve garrFolders(1 To glngFolder)
- 'Pfadname
- garrFolders(glngFolder) = SourceFolderName
- For Each SubFolder In SourceFolder.SubFolders
- ListFoldersInFolder SubFolder.Path
- Next SubFolder
- Err_Zugriff:
- Set SourceFolder = Nothing: Set FSO = Nothing
- End Sub
Hat jemand eine Ahnung, was hier das Problem an dem einem Rechner verursacht / verursachen könnte?
Besten Dank im Voraus für Eure Unterstützung
Spoiler hinzugefügt ~VaporiZed
Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „VaporiZed“ ()