objFileDialog umändern

Hallo liebe Helfer!!!
ich habe einen super CODE, mit dem ich mittels objFileDialog einen Ordner wählen konnte und dann die META-Daten aller Dateien auslesen konnte. Funktioniert perfekt funktioniert...
Diesen muss ich jetzt aber (möglichst aufwandsarm) so anpassen, dass er nacheinander eine kleine UNC-Pfad Liste abarbeitet, und genaud das gleiche macht wie vorher. Nur eben nicht nur für einen manuell ausgewählten Ordner, sondern für mehrere (sind ca. 5 im BEreich A2 bis A10) einer weiteren Tabelle.
Hier mein bisheriger CODE (habe NICHT relevantes Zeug rausgenommen...) ... Wir hat eine Idee, wie ich möglichst wenig anpassen muss? DANKE DANKE DANKE


Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(.SelectedItems(1))
astrFolders = GetFolders(.SelectedItems(1) & "\")
HauptOrdnerString = objFolder.Title
' Jeden Ordner (zunächst den Hauptordr, dann die unterordner, durchlaufen
For Each vntFolder In astrFolders
Set objFolder = objShell.Namespace(vntFolder)
' Alle Zeilen d.h. Dateien durchlaufen
For Each vntFileName In objFolder.items
Do Until lngIndex = 333
If objFolder.GetDetailsOf(vntFileName, lngIndex)  "" Then
Worksheets(1).Cells(Startzeile + lngRow, vonSpalte + i) = objFolder.GetDetailsOf(vntFileName, lngIndex)
End If
i = i + 1
lngIndex = lngIndex + 1
Loop
lngRow = lngRow + 1
lngIndex = 1
i = 2
Next
Next

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim rngC As Range Set objShell = CreateObject("Shell.Application") For Each rngC In Range("A2:A10") Set objFolder = objShell.Namespace(rngC) astrFolders = GetFolders(rngC & "\") HauptOrdnerString = objFolder.Title ' Jeden Ordner (zunächst den Hauptordr, dann die unterordner, durchlaufen For Each vntFolder In astrFolders Set objFolder = objShell.Namespace(vntFolder) ' Alle Zeilen d.h. Dateien durchlaufen For Each vntFileName In objFolder.items Do Until lngIndex = 333 If objFolder.GetDetailsOf(vntFileName, lngIndex) "" Then Worksheets(1).Cells(Startzeile + lngRow, vonSpalte + i) = _ objFolder.GetDetailsOf(vntFileName, lngIndex) End If i = i + 1 lngIndex = lngIndex + 1 Loop lngRow = lngRow + 1 lngIndex = 1 i = 2 Next Next Next rngC

Private Function GetFolders(ByVal pvstrPath As String) As String() Dim astrFolders() As String Dim strFolder As String, strPath As String Dim ialngIndex1 As Long, ialngIndex2 As Long ReDim Preserve astrFolders(ialngIndex1) astrFolders(ialngIndex1) = pvstrPath ialngIndex1 = 1 ialngIndex2 = 1 strPath = pvstrPath Do strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory) Do Until strFolder = vbNullString If strFolder "." And strFolder ".." Then If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then ReDim Preserve astrFolders(0 To ialngIndex1) astrFolders(ialngIndex1) = strPath & strFolder & "\" ialngIndex1 = ialngIndex1 + 1 End If End If strFolder = Dir$ Loop If ialngIndex1 = ialngIndex2 Then Exit Do strPath = astrFolders(ialngIndex2) ialngIndex2 = ialngIndex2 + 1 Loop GetFolders = astrFolders End Function

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread