Dateieigenschaften werden von einem Rechner NICHT eingelesen

  • Excel

    Dateieigenschaften werden von einem Rechner NICHT eingelesen

    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

    Visual Basic-Quellcode

    1. Option Explicit
    2. Public glngFolder As Long, garrFolders() As Variant
    4. Sub Dateeigenschaften_gezielt()
    5. 'Stufe 1
    6. 'Einlesen der (Unter-)Ordner, Dateitypen (#164), Pfade (#194) und evtl. Verlinkungen (#203)
    7. Call Dateieigenschaften("P:\qm\_Management-Dokumentation\Ablage\", _
    8. varEigenschaften:=Array(164, 194, 203), NrIndex:=False)
    9. End Sub
    11. Private Sub Dateieigenschaften _
    12. (ByVal STRFOLDER As Variant, _
    13. Optional varEigenschaften As Variant, _
    14. Optional NrIndex As Boolean = False, _
    15. Optional bolUnterOrdner As Boolean = True)
    17. 'STRFOLDER: Ordner in dem die Eigenschaften der Dateien ausgelesen werden sollen
    18. 'varEigenschaften: Array mit den Index-Nummern der Eigenschaften, die ausgelesen werden sollen
    19. 'wird der parameter weggelassen, werden alle Eigenschaften ausgelesen
    20. 'NrIndex: optional, wenn True, dann werden in Zeile 1 die Index-Nrn der Eigenschaften ausgegeben
    21. 'bolUnterOrdner:optional, wenn True, dann wird in Spalte A das Unterverzeichnis der Datei ausgegeben
    23. Dim objShell As Object
    24. Dim objFolder As Object
    25. Dim x As Byte
    26. Dim intColumn As Integer
    27. Dim lngRow As Long
    28. Dim varName, arrHeaders(255)
    29. Dim varWert
    30. Dim wksAusgabe As Worksheet
    32. 'Statusbar einblenden
    33. Application.ScreenUpdating = True
    34. Application.DisplayStatusBar = True
    36. 'Abfrage, ob aktualisiert werden soll
    37. If MsgBox("Soll die Übersicht aktualisert werden?" & Chr(13) & Chr(13) & _
    38. "(das kann u.U. etwas dauern)", vbYesNoCancel) = vbYes Then
    39. GoTo SPRUNG1
    40. Else
    41. If MsgBox("ACHTUNG!" & Chr(13) & Chr(13) & _
    42. "Sie haben der Aktualisierung nicht zugestimmt." & Chr(13) & _
    43. "Es besteht somit die Gefahr, dass Sie mit einem veraltetem Stand arbeiten und somit nicht alle relevanten Daten angezeigt bekommen." & Chr(13) & Chr(13) & _
    44. "Möchten Sie die Übersicht doch noch aktualisieren?", vbYesNoCancel) = vbYes Then
    45. GoTo SPRUNG1
    46. Else
    47. MsgBox "Aktualisierung wurde abgebrochen."
    48. Exit Sub
    49. End If
    50. End If
    52. SPRUNG1:
    53. 'Prüfen, ob Ablage vorhanden
    54. If Dir(STRFOLDER, 16) = "" Then
    55. MsgBox "Der Ordner " & STRFOLDER & " wurde nicht gefunden!" & Space(10), 64, "weise hin..."
    56. Exit Sub
    57. End If
    59. 'Tabelle entsperren
    60. Tabelle1.Unprotect
    62. 'Tabelle leeren
    63. Dim letzteZeile As Integer
    64. letzteZeile = Tabelle1.Cells(Rows.Count, 6).End(xlUp).Row
    65. Tabelle1.Range("B21:P" & letzteZeile).ClearContents
    67. 'Ordnerliste zurücksetzen
    68. glngFolder = 0
    69. Erase garrFolders
    71. 'Anzeige Statusbar einstellen
    72. Application.StatusBar = "Ordner im Verzeichnis """ & STRFOLDER & """ werden eingelesen"
    74. 'Makro für Unterordner aufrufen
    75. Call ListFoldersInFolder(SourceFolderName:=STRFOLDER)
    77. Set objShell = CreateObject("Shell.Application")
    79. 'Start Einlesen
    80. For glngFolder = 1 To UBound(garrFolders)
    82. 'Anzeige in Statusbar
    83. Application.StatusBar = "Schritt 1 von 3 >>> Dateien im Verzeichnis """ & _
    84. garrFolders(glngFolder) & """ werden eingelesen (Ordner " & glngFolder & _
    85. " von " & UBound(garrFolders) & " )"
    87. 'Bildschirmaktualisierung ausschalten
    88. With Application
    89. .ScreenUpdating = False
    90. .Calculation = xlCalculationManual
    91. .EnableEvents = False
    92. End With
    94. Set objFolder = objShell.Namespace(garrFolders(glngFolder))
    96. If glngFolder = 1 Then
    97. 'On Error Resume Next
    98. Set wksAusgabe = Tabelle1
    100. intColumn = 1
    102. 'Unterverzeichnis angeben
    103. If bolUnterOrdner = True Then
    104. intColumn = intColumn + 1
    105. With wksAusgabe
    106. If NrIndex = True Then
    107. .Cells(2, intColumn) = "Unterverzeichnis"
    108. Else
    109. .Cells(1, intColumn) = "Unterverzeichnis"
    110. End If
    111. End With
    112. End If
    114. 'Index-Nummer und Namen der Dateieigenschaften
    115. For x = 0 To 254
    117. If fncCheck(IIf(VBA.IsMissing(varEigenschaften), -1, x), varEigenschaften) Then
    118. intColumn = intColumn + 1
    119. arrHeaders(x) = objFolder.GetDetailsOf(varName, x)
    120. With wksAusgabe
    121. If NrIndex = True Then
    122. .Cells(19, intColumn) = x
    123. .Cells(20, intColumn) = arrHeaders(x)
    124. Else
    125. .Cells(20, intColumn) = arrHeaders(x)
    126. End If
    127. End With
    128. End If
    129. Next
    131. 'Anfang Auflistung
    132. If NrIndex = True Then
    133. wksAusgabe.Rows(20).Font.Bold = True
    134. lngRow = 21 'Start der Detail-Auflistung
    135. Else
    136. wksAusgabe.Rows(20).Font.Bold = True
    137. lngRow = 21 'Start der Detail-Auflistung
    138. End If
    140. End If
    142. 'Details auflisten
    143. For Each varName In objFolder.Items
    145. Select Case LCase(objFolder.GetDetailsOf(varName, 2))
    146. Case "dateiordner", "folder", "filefolder"
    147. 'Ordner in Dateiliste nicht ausgeben
    148. Case Else
    149. intColumn = 1
    151. 'Unterordner auflisten
    152. If bolUnterOrdner = True Then
    153. intColumn = intColumn + 1
    154. wksAusgabe.Cells(lngRow, intColumn) = "'" & Mid(garrFolders(glngFolder), Len(STRFOLDER) + 1)
    155. End If
    157. For x = 0 To 254
    159. 'Eigenschaften
    160. If fncCheck(IIf(IsMissing(varEigenschaften), -1, x), varEigenschaften) Then
    161. intColumn = intColumn + 1
    162. varWert = ""
    163. varWert = objFolder.GetDetailsOf(varName, x)
    165. Select Case x
    166. Case 3, 4, 5, 152, 153, 154 'Datum Zeit
    167. If IsDate(varWert) Then varWert = CDate(varWert)
    168. Case 12 'Aufnahmedatum (enthält sonderzeichen deshalb keine echtes Exceldatum
    169. If IsDate(varWert) Then
    170. varWert = CDate(varWert)
    171. End If
    172. Case Else
    173. varWert = "'" & varWert
    174. End Select
    175. wksAusgabe.Cells(lngRow, intColumn) = varWert
    176. End If
    177. Next
    178. lngRow = lngRow + 1
    179. End Select
    180. Next
    181. Next glngFolder
    183. 'Bildschirmaktualisierung einschalten
    184. With Application
    185. .ScreenUpdating = True
    186. .Calculation = xlCalculationAutomatic
    187. .EnableEvents = True
    188. End With
    190. 'Info-Box
    191. MsgBox "Übersicht wurde aktualisiert"
    193. 'Ordnerliste zurücksetzen
    194. glngFolder = 0
    195. Erase garrFolders
    197. 'Statusleiste zurücksetzen
    198. Application.StatusBar = False
    200. 'Tabelle sperren
    201. Tabelle1.Range("A1").Select
    202. Tabelle1.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
    204. End Sub
    206. Private Function fncCheck(ByVal x As Integer, Optional varWerte) As Boolean
    208. Dim intJ As Integer
    209. fncCheck = False
    211. If x < 0 Then 'alle Eigenschaften
    212. fncCheck = True
    213. Else
    214. For intJ = LBound(varWerte) To UBound(varWerte)
    215. If x = varWerte(intJ) Then
    216. fncCheck = True
    217. Exit For
    218. End If
    219. Next
    220. End If
    222. End Function
    224. Private Sub ListFoldersInFolder(ByVal SourceFolderName As String)
    225. 'Makro erstellt zum Ordner-Namen ein Daten-Array mit den Namen der Ordner im Verzeichnis inkl. Unterverzeichnissen
    227. Dim FSO As Object, SourceFolder As Object, SubFolder As Object
    229. Set FSO = CreateObject("Scripting.FileSystemObject")
    230. Set SourceFolder = FSO.GetFolder(SourceFolderName)
    232. On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
    234. glngFolder = glngFolder + 1
    235. ReDim Preserve garrFolders(1 To glngFolder)
    237. 'Pfadname
    238. garrFolders(glngFolder) = SourceFolderName
    240. For Each SubFolder In SourceFolder.SubFolders
    241. ListFoldersInFolder SubFolder.Path
    242. Next SubFolder
    244. Err_Zugriff:
    245. Set SourceFolder = Nothing: Set FSO = Nothing
    247. 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“ ()

Facebook
Telefonspende