Thema Datum  Von Nutzer Rating
Antwort
06.08.2018 14:24:48 Lars
NotSolved
06.08.2018 21:44:03 Gast27383
NotSolved
07.08.2018 07:00:20 Lars
NotSolved
Blau Unterprogramm durchsuchen
07.08.2018 07:49:50 SJ
NotSolved
07.08.2018 08:10:12 Lars
NotSolved
07.08.2018 09:02:11 SJ
NotSolved
07.08.2018 09:24:03 Lars
NotSolved
07.08.2018 09:55:42 Gast42041
NotSolved
07.08.2018 10:21:48 Lars
NotSolved
07.08.2018 13:04:06 Gast17377
NotSolved
07.08.2018 13:11:18 Lars
NotSolved
07.08.2018 16:39:08 Gast8743
NotSolved
07.08.2018 20:18:45 Gast56205
Solved
08.08.2018 07:27:30 Lars
NotSolved
08.08.2018 08:40:18 Lars
NotSolved

Ansicht des Beitrags:
Von:
SJ
Datum:
07.08.2018 07:49:50
Views:
587
Rating: Antwort:
  Ja
Thema:
Unterprogramm durchsuchen

Hallo,

vielleicht hilft dir dieses Makro weiter:

Option Explicit

Const WKS_NAME As String = "Tabelle1"   'Tabelle, in der die Liste erzeugt werden soll
Const PFAD As String = "C:\usw." 'Pfad des Startverzeichnis
Dim fso As FileSystemObject
Dim wks As Worksheet
Dim f As folder

Public Sub list_all_files()
    Set fso = New FileSystemObject
    Set wks = Worksheets(WKS_NAME)
    
    With wks
        .Cells.ClearContents
        .Cells(1, 1) = "DateiPfad"
        .Cells(1, 2) = "Name"
        .Cells(1, 3) = "Erstellungsdatum"
        .Cells(1, 4) = "Dateityp"
        .Cells(1, 5) = "Autor"
    End With
    
    Call get_all_files_of_subfolder(PFAD)
    
    Set wks = Nothing
End Sub

Private Sub get_all_files_of_subfolder(ByVal sPfad As String)
    Dim fo As folder
    Dim sfo As Folders
    Dim fi As file
    Dim i As Integer
    Set fo = fso.GetFolder(sPfad)
    Set sfo = fo.SubFolders
    i = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row + 1
    
    For Each fi In fo.Files
        With wks
            .Cells(i, 1) = fi.Path
            .Cells(i, 2) = fi.Name
            .Cells(i, 3) = fi.DateCreated
            .Cells(i, 4) = fi.Type
            .Cells(i, 5) = get_file_author(fi.Path)
        End With
        i = i + 1
    Next
    For Each f In sfo
        Call get_all_files_of_subfolder(f.Path)
    Next
End Sub

Private Function get_file_author(ByVal sPfad As String) As String
    Dim oShell As Object
    Set oShell = CreateObject("Shell.Application")
        
    With oShell.Namespace(fso.GetParentFolderName(sPfad))
        get_file_author = .GetDetailsOf(.Items.Item(fso.GetFileName(sPfad)), 20)
    End With
    
    Set oShell = Nothing
End Function

Im Projekt wird der Verweis zur Scripting Runtime benötigt.

Gruß


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
06.08.2018 14:24:48 Lars
NotSolved
06.08.2018 21:44:03 Gast27383
NotSolved
07.08.2018 07:00:20 Lars
NotSolved
Blau Unterprogramm durchsuchen
07.08.2018 07:49:50 SJ
NotSolved
07.08.2018 08:10:12 Lars
NotSolved
07.08.2018 09:02:11 SJ
NotSolved
07.08.2018 09:24:03 Lars
NotSolved
07.08.2018 09:55:42 Gast42041
NotSolved
07.08.2018 10:21:48 Lars
NotSolved
07.08.2018 13:04:06 Gast17377
NotSolved
07.08.2018 13:11:18 Lars
NotSolved
07.08.2018 16:39:08 Gast8743
NotSolved
07.08.2018 20:18:45 Gast56205
Solved
08.08.2018 07:27:30 Lars
NotSolved
08.08.2018 08:40:18 Lars
NotSolved