Macro zur Inhaltsauflistung eines Ordner
29.04.2021 10:35:21
Paul
wir haben folgende Problematik:
Wir wollen ein Inhaltsverzeichnis via Makro von Ordnern, welche sich auf einer Onedrive befinden, erstellen. Wir haben folgendes Makro (unten angehängt), haben damit aber noch kleinere Probleme.
1. Wir können momentan nur lokale Ordner auswählen, die OneDrive Ordner welche man normalerweise neben anderen Festplatten auswählen kann, werden in der Auswahl nicht angezeigt. Gibt es da irgendeine Lösung?
2. Als zusätzliche Hilfe, hätten wir gerne eine Leiste links, wie im angehängten Foto gezeigt. Hat da jemand eine Idee wie wir das hinbekommen könnten?
3. Die Auflistung der Dateien und Ordner soll erst in der zweiten Zeile beginnen. Wie bauen wir das am besten wo ein?
Code:
Option Explicit
Dim lngColumn As Integer
Dim objFSO As Object
Dim objFOL As Object
Dim objFIL As Object
Dim objFO As Object
Dim objFU As Object
Dim lngRow As Long
Public Sub Ordner_Dateien_Auflisten()
Dim objShell As Object
Dim varDir As Variant
Dim strTMP As String
Set objShell = CreateObject("Shell.Application")
Set varDir = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
Application.ScreenUpdating = False
On Error Resume Next
strTMP = varDir.Self.Path
On Error GoTo 0
On Error GoTo Fin
If strTMP "" And Left(strTMP, 2) "::" Then
If Right(strTMP, 1) "\" Then strTMP = strTMP & "\"
End If
Set objFSO = CreateObject("Scripting.FileSystemObject")
Tabelle1.Cells.Clear ' eventuell anpassen
lngRow = 0
lngColumn = 0
GetSubFolders_Files strTMP
Tabelle1.Columns.AutoFit
Fin:
Application.ScreenUpdating = True
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
Set objShell = Nothing
Set varDir = Nothing
End Sub
Private Function GetSubFolders_Files(ByVal strPath As String) As String
Set objFO = objFSO.GetFolder(strPath)
Set objFU = objFO.SubFolders
With Tabelle1 ' eventuell anpassen
lngRow = lngRow + 1
lngColumn = lngColumn + 1
.Cells(lngRow, lngColumn).NumberFormat = "@"
.Cells(lngRow, lngColumn) = objFO.Name
.Hyperlinks.Add _
Anchor:=.Cells(lngRow, lngColumn), _
Address:=strPath, _
TextToDisplay:=.Cells(lngRow, lngColumn).Value
.Cells(lngRow, lngColumn).Font.Bold = True
.Cells(lngRow, lngColumn).Font.ColorIndex = 3
For Each objFIL In objFO.Files
lngRow = lngRow + 1
.Cells(lngRow, lngColumn + 1) = objFIL.Name
.Hyperlinks.Add _
Anchor:=.Cells(lngRow, lngColumn + 1), _
Address:=objFIL.Path, _
TextToDisplay:=.Cells(lngRow, lngColumn + 1).Value
Next objFIL
End With
For Each objFOL In objFU
GetSubFolders_Files objFOL.Path
Next objFOL
lngColumn = lngColumn - 1
End Function
